diff --git a/base/internals/psi_desc_impl.f90 b/base/internals/psi_desc_impl.f90 index d37fe87e..6ef91964 100644 --- a/base/internals/psi_desc_impl.f90 +++ b/base/internals/psi_desc_impl.f90 @@ -88,7 +88,7 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) debug_unit = psb_get_debug_unit() info = psb_success_ - ictxt = cdesc%matrix_data(psb_ctxt_) + ictxt = psb_cd_get_context(cdesc) call psb_info(ictxt,me,np) if (np == -1) then @@ -107,9 +107,9 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) goto 9999 end if call psb_move_alloc(idx_out,cdesc%halo_index,info) - cdesc%matrix_data(psb_thal_xch_) = nxch - cdesc%matrix_data(psb_thal_snd_) = nsnd - cdesc%matrix_data(psb_thal_rcv_) = nrcv +!!$ cdesc%matrix_data(psb_thal_xch_) = nxch +!!$ cdesc%matrix_data(psb_thal_snd_) = nsnd +!!$ cdesc%matrix_data(psb_thal_rcv_) = nrcv if (debug_level>0) write(debug_unit,*) me,'Done crea_index on halo' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext' @@ -123,9 +123,9 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) goto 9999 end if call psb_move_alloc(idx_out,cdesc%ext_index,info) - cdesc%matrix_data(psb_text_xch_) = nxch - cdesc%matrix_data(psb_text_snd_) = nsnd - cdesc%matrix_data(psb_text_rcv_) = nrcv +!!$ cdesc%matrix_data(psb_text_xch_) = nxch +!!$ cdesc%matrix_data(psb_text_snd_) = nsnd +!!$ cdesc%matrix_data(psb_text_rcv_) = nrcv if (debug_level>0) write(debug_unit,*) me,'Done crea_index on ext' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap' @@ -142,9 +142,9 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) goto 9999 end if - cdesc%matrix_data(psb_tovr_xch_) = nxch - cdesc%matrix_data(psb_tovr_snd_) = nsnd - cdesc%matrix_data(psb_tovr_rcv_) = nrcv +!!$ cdesc%matrix_data(psb_tovr_xch_) = nxch +!!$ cdesc%matrix_data(psb_tovr_snd_) = nsnd +!!$ cdesc%matrix_data(psb_tovr_rcv_) = nrcv ! next ovrlap_elem if (debug_level>0) write(debug_unit,*) me,'Calling crea_ovr_elem' @@ -170,9 +170,9 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info) goto 9999 end if - cdesc%matrix_data(psb_tmov_xch_) = nxch - cdesc%matrix_data(psb_tmov_snd_) = nsnd - cdesc%matrix_data(psb_tmov_rcv_) = nrcv +!!$ cdesc%matrix_data(psb_tmov_xch_) = nxch +!!$ cdesc%matrix_data(psb_tmov_snd_) = nsnd +!!$ cdesc%matrix_data(psb_tmov_rcv_) = nrcv ! finally bnd_elem call psi_crea_bnd_elem(idx_out,cdesc,info) diff --git a/base/internals/psi_idx_ins_cnv.f90 b/base/internals/psi_idx_ins_cnv.f90 index c550768e..6a3aceb6 100644 --- a/base/internals/psi_idx_ins_cnv.f90 +++ b/base/internals/psi_idx_ins_cnv.f90 @@ -119,7 +119,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) goto 9999 end if - desc%matrix_data(psb_n_col_) = desc%indxmap%get_lc() +!!$ desc%matrix_data(psb_n_col_) = desc%indxmap%get_lc() call psb_erractionrestore(err_act) return diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 8f0eae7e..647354cb 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -200,7 +200,7 @@ module psb_descriptor_type type psb_desc_type - integer, allocatable :: matrix_data(:) +!!$ integer, allocatable :: matrix_data(:) integer, allocatable :: halo_index(:) integer, allocatable :: ext_index(:) integer, allocatable :: ovrlap_index(:) @@ -241,16 +241,11 @@ module psb_descriptor_type module procedure psb_is_bld_desc end interface psb_is_bld_desc - interface psb_is_large_desc - module procedure psb_is_large_desc - end interface psb_is_large_desc - interface psb_move_alloc module procedure psb_cdtransfer end interface psb_move_alloc - interface psb_free module procedure psb_cdfree end interface psb_free @@ -269,7 +264,7 @@ contains integer(psb_long_int_k_) :: val val = 0 - if (allocated(desc%matrix_data)) val = val + psb_sizeof_int*size(desc%matrix_data) +!!$ if (allocated(desc%matrix_data)) val = val + psb_sizeof_int*size(desc%matrix_data) if (allocated(desc%halo_index)) val = val + psb_sizeof_int*size(desc%halo_index) if (allocated(desc%ext_index)) val = val + psb_sizeof_int*size(desc%ext_index) if (allocated(desc%bnd_elem)) val = val + psb_sizeof_int*size(desc%bnd_elem) @@ -354,14 +349,6 @@ contains end function psb_is_bld_desc - function psb_is_large_desc(desc) result(val) - type(psb_desc_type), intent(in) :: desc - logical :: val - - val = .false. - - end function psb_is_large_desc - function psb_is_upd_desc(desc) result(val) type(psb_desc_type), intent(in) :: desc logical :: val @@ -625,11 +612,11 @@ contains name = 'psb_cdfree' - if (.not.allocated(desc_a%matrix_data)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if +!!$ if (.not.allocated(desc_a%matrix_data)) then +!!$ info=psb_err_forgot_spall_ +!!$ call psb_errpush(info,name) +!!$ return +!!$ end if ictxt=psb_cd_get_context(desc_a) @@ -723,7 +710,7 @@ contains end if end if - deallocate(desc_a%matrix_data) +!!$ deallocate(desc_a%matrix_data) call psb_nullify_desc(desc_a) @@ -783,7 +770,7 @@ contains ! function might be called even when desc_in is ! empty. - call psb_move_alloc( desc_in%matrix_data , desc_out%matrix_data , info) +!!$ call psb_move_alloc( desc_in%matrix_data , desc_out%matrix_data , info) if (info == psb_success_) & & call psb_move_alloc( desc_in%halo_index , desc_out%halo_index , info) if (info == psb_success_) & diff --git a/base/serial/Makefile b/base/serial/Makefile index 8dd5292a..cd20e8cd 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -11,7 +11,7 @@ LIBDIR=.. MODDIR=../modules FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG). -lib: auxd f77d f03d lib1 +lib: auxd f77d impld lib1 $(AR) $(LIBDIR)/$(LIBNAME) $(FOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) @@ -25,13 +25,13 @@ auxd: f77d: (cd f77; $(MAKE) lib) -f03d: - (cd f03; $(MAKE) lib) +impld: + (cd impl; $(MAKE) lib) clean: /bin/rm -f $(FOBJS) *$(.mod) (cd aux; $(MAKE) clean) (cd f77; $(MAKE) clean) - (cd f03; $(MAKE) clean) + (cd impl; $(MAKE) clean) veryclean: clean diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile new file mode 100644 index 00000000..68d82f50 --- /dev/null +++ b/base/serial/impl/Makefile @@ -0,0 +1,44 @@ +include ../../../Make.inc + +# +# The object files +# +BOBJS=psb_base_mat_impl.o psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o +SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o +DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o +COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o +ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o + +OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) + +# +# Where the library should go, and how it is called. +# Note that we are regenerating most of libsparker.a on the fly. +SPARKERDIR=.. +LIBDIR=../.. +MODDIR=../../modules +FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG)$(SPARKERDIR) $(FMFLAG). +#LIBNAME=libsparker.a +LIBFILE=$(LIBDIR)/$(LIBNAME) + +# +# No change should be needed below +# + + +default: lib + +lib: $(OBJS) + $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) + $(RANLIB) $(LIBDIR)/$(LIBNAME) + +# A bit excessive, but safe +$(OBJS): $(MODDIR)/psb_sparse_mod.o + +clean: cleanobjs + +veryclean: cleanobjs + +cleanobjs: + /bin/rm -f $(OBJS) + diff --git a/base/serial/impl/psb_base_mat_impl.f90 b/base/serial/impl/psb_base_mat_impl.f90 new file mode 100644 index 00000000..514b0d98 --- /dev/null +++ b/base/serial/impl/psb_base_mat_impl.f90 @@ -0,0 +1,337 @@ +function psb_base_get_nz_row(idx,a) result(res) + use psb_error_mod + use psb_base_mat_mod, psb_protect_name => psb_base_get_nz_row + implicit none + integer, intent(in) :: idx + class(psb_base_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act + character(len=20) :: name='base_get_nz_row' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end function psb_base_get_nz_row + +function psb_base_get_nzeros(a) result(res) + use psb_base_mat_mod, psb_protect_name => psb_base_get_nzeros + use psb_error_mod + implicit none + class(psb_base_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act + character(len=20) :: name='base_get_nzeros' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end function psb_base_get_nzeros + +function psb_base_get_size(a) result(res) + use psb_base_mat_mod, psb_protect_name => psb_base_get_size + use psb_error_mod + implicit none + class(psb_base_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act + character(len=20) :: name='get_size' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end function psb_base_get_size + +subroutine psb_base_reinit(a,clear) + use psb_base_mat_mod, psb_protect_name => psb_base_reinit + use psb_error_mod + implicit none + + class(psb_base_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_err_missing_override_method_ + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_reinit + +subroutine psb_base_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_base_mat_mod, psb_protect_name => psb_base_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_base_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_err_missing_override_method_ + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_sparse_print + +subroutine psb_base_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_base_mat_mod, psb_protect_name => psb_base_csgetptn + implicit none + + class(psb_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_csgetptn + +subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev) + use psb_base_mat_mod, psb_protect_name => psb_base_get_neigh + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_base_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + integer :: lev_, i, nl, ifl,ill,& + & n1, err_act, nn, nidx,ntl,ma + integer, allocatable :: ia(:), ja(:) + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if(present(lev)) then + lev_ = lev + else + lev_=1 + end if + ! Turns out we can write get_neigh at this + ! level + n = 0 + ma = a%get_nrows() + call a%csget(idx,idx,n,ia,ja,info) + if (info == psb_success_) call psb_realloc(n,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + neigh(1:n) = ja(1:n) + ifl = 1 + ill = n + do nl = 2, lev_ + n1 = ill - ifl + 1 + call psb_ensure_size(ill+n1*n1,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + ntl = 0 + do i=ifl,ill + nidx=neigh(i) + if ((nidx /= idx).and.(nidx > 0).and.(nidx <= ma)) then + call a%csget(nidx,nidx,nn,ia,ja,info) + if (info == psb_success_) call psb_ensure_size(ill+ntl+nn,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) + ntl = ntl+nn + end if + end do + call psb_msort_unique(neigh(ill+1:ill+ntl),nn) + ifl = ill + 1 + ill = ill + nn + end do + call psb_msort_unique(neigh(1:ill),nn,dir=psb_sort_up_) + n = nn + + call psb_erractionrestore(err_act) + return + +9999 continue + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_get_neigh + +subroutine psb_base_allocate_mnnz(m,n,a,nz) + use psb_base_mat_mod, psb_protect_name => psb_base_allocate_mnnz + use psb_error_mod + implicit none + integer, intent(in) :: m,n + class(psb_base_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_allocate_mnnz + +subroutine psb_base_reallocate_nz(nz,a) + use psb_base_mat_mod, psb_protect_name => psb_base_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_base_sparse_mat), intent(inout) :: a + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_reallocate_nz + +subroutine psb_base_free(a) + use psb_base_mat_mod, psb_protect_name => psb_base_free + use psb_error_mod + implicit none + class(psb_base_sparse_mat), intent(inout) :: a + Integer :: err_act + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_free + +subroutine psb_base_trim(a) + use psb_base_mat_mod, psb_protect_name => psb_base_trim + use psb_error_mod + implicit none + class(psb_base_sparse_mat), intent(inout) :: a + Integer :: err_act + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_base_trim + diff --git a/base/serial/impl/psb_c_base_mat_impl.f90 b/base/serial/impl/psb_c_base_mat_impl.f90 new file mode 100644 index 00000000..4e8ce78f --- /dev/null +++ b/base/serial/impl/psb_c_base_mat_impl.f90 @@ -0,0 +1,1102 @@ +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_c_base_cp_to_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_cp_to_coo + +subroutine psb_c_base_cp_from_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_cp_from_coo + + +subroutine psb_c_base_cp_to_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_cp_to_fmt + +subroutine psb_c_base_cp_from_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_cp_from_fmt + + +subroutine psb_c_base_mv_to_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_mv_to_coo + +subroutine psb_c_base_mv_from_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_mv_from_coo + + +subroutine psb_c_base_mv_to_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_mv_to_fmt + +subroutine psb_c_base_mv_from_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_mv_from_fmt + +subroutine psb_c_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_csput + +subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csgetrow + implicit none + + class(psb_c_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_csgetrow + + + +subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csgetblk + implicit none + + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_base_csgetblk + + +subroutine psb_c_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csclip + implicit none + + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_base_csclip + +subroutine psb_c_base_mold(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mold + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_mold + +subroutine psb_c_base_transp_2mat(a,b) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_c_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='c_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_c_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_c_base_transp_2mat + +subroutine psb_c_base_transc_2mat(a,b) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transc_2mat + implicit none + + class(psb_c_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transc(b) +end subroutine psb_c_base_transc_2mat + +subroutine psb_c_base_transp_1mat(a) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(inout) :: a + + type(psb_c_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='c_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_c_base_transp_1mat + +subroutine psb_c_base_transc_1mat(a) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transc_1mat + implicit none + + class(psb_c_base_sparse_mat), intent(inout) :: a + + call a%transc() +end subroutine psb_c_base_transc_1mat + + +! == ================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == ================================== + +subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csmm + use psb_error_mod + + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_csmm + + +subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csmv + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + +end subroutine psb_c_base_csmv + + +subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_inner_cssm + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_inner_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_inner_cssm + + +subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_inner_cssv + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_inner_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_inner_cssv + + +subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cssm + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + + complex(psb_spk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='c_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == psb_success_)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else if (psb_toupper(scale_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& + & call a%inner_cssm(cone,x,czero,tmp,info,trans) + + if (info == psb_success_)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == psb_success_)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_c_base_cssm + + +subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cssv + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + + complex(psb_spk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='c_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + if (info == psb_success_)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else if (psb_toupper(scale_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + if (beta == czero) then + call a%inner_cssm(alpha,x,czero,y,info,trans) + if (info == psb_success_) call inner_vscal1(nar,d,y) + else + allocate(tmp(nar),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& + & call a%inner_cssm(alpha,x,czero,tmp,info,trans) + + if (info == psb_success_) call inner_vscal1(nar,d,tmp) + if (info == psb_success_)& + & call psb_geaxpby(nar,cone,tmp,beta,y,info) + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +contains + subroutine inner_vscal(n,d,x,y) + implicit none + integer, intent(in) :: n + complex(psb_spk_), intent(in) :: d(*),x(*) + complex(psb_spk_), intent(out) :: y(*) + integer :: i + + do i=1,n + y(i) = d(i)*x(i) + end do + end subroutine inner_vscal + + + subroutine inner_vscal1(n,d,x) + implicit none + integer, intent(in) :: n + complex(psb_spk_), intent(in) :: d(*) + complex(psb_spk_), intent(inout) :: x(*) + integer :: i + + do i=1,n + x(i) = d(i)*x(i) + end do + end subroutine inner_vscal1 + +end subroutine psb_c_base_cssv + + +subroutine psb_c_base_scals(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_scals + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='c_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_scals + + + +subroutine psb_c_base_scal(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_scal + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='c_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_base_scal + + + +function psb_c_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csnmi + + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -done + + return + +end function psb_c_base_csnmi + +subroutine psb_c_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_get_diag + + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_c_base_get_diag + + + + diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 new file mode 100644 index 00000000..61158f65 --- /dev/null +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -0,0 +1,3234 @@ + +subroutine psb_c_coo_get_diag(a,d,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = czero + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = cone + else + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_get_diag + + +subroutine psb_c_coo_scal(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_scal + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_scal + + +subroutine psb_c_coo_scals(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_scals + + +subroutine psb_c_coo_reallocate_nz(nz,a) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_c_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='c_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_reallocate_nz + +subroutine psb_c_coo_mold(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_mold + use psb_error_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_c_coo_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_coo_mold + + +subroutine psb_c_coo_reinit(a,clear) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_reinit + use psb_error_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_reinit + + + +subroutine psb_c_coo_trim(a) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_trim + + +subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_c_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_allocate_mnnz + + + +subroutine psb_c_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_print + use psb_string_mod + implicit none + + integer, intent(in) :: iout + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='c_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_c_coo_print + + + + +function psb_c_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_get_nz_row + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_c_coo_get_nz_row + +subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cssm + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:,:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_base_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + nc = min(size(x,2) , size(y,2)) + nnz = a%get_nzeros() + + if (alpha == zzero) then + if (beta == zzero) then + do i = 1, m + y(i,1:nc) = zzero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + return + end if + + if (beta == zzero) then + call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & m,nc,nnz,a%ia,a%ja,a%val,& + & x,size(x,1),y,size(y,1),info) + do i = 1, m + y(i,1:nc) = alpha*y(i,1:nc) + end do + else + allocate(tmp(m,nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & m,nc,nnz,a%ia,a%ja,a%val,& + & x,size(x,1),tmp,size(tmp,1),info) + do i = 1, m + y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) + end do + end if + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='inner_coosm') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& + & ia,ja,val,x,ldx,y,ldy,info) + implicit none + logical, intent(in) :: tra,ctra,lower,unit,sorted + integer, intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) + complex(psb_spk_), intent(in) :: val(*), x(ldx,*) + complex(psb_spk_), intent(out) :: y(ldy,*) + integer, intent(out) :: info + + integer :: i,j,k,m, ir, jc + complex(psb_spk_), allocatable :: acc(:) + + info = psb_success_ + allocate(acc(nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + + + if (.not.sorted) then + info = psb_err_invalid_mat_state_ + return + end if + + nnz = nz + + if ((.not.tra).and.(.not.ctra)) then + + if (lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = zzero + do + if (j > nnz) exit + if (ia(j) > i) exit + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j + 1 + end do + y(i,1:nc) = x(i,1:nc) - acc(1:nc) + end do + else if (.not.unit) then + j = 1 + do i=1, nr + acc(1:nc) = zzero + do + if (j > nnz) exit + if (ia(j) > i) exit + if (ja(j) == i) then + y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) + j = j + 1 + exit + end if + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j + 1 + end do + end do + end if + + else if (.not.lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = zzero + do + if (j < 1) exit + if (ia(j) < i) exit + acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) + j = j - 1 + end do + y(i,1:nc) = x(i,1:nc) - acc(1:nc) + end do + + else if (.not.unit) then + + j = nnz + do i=nr, 1, -1 + acc(1:nc) = zzero + do + if (j < 1) exit + if (ia(j) < i) exit + if (ja(j) == i) then + y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) + j = j - 1 + exit + end if + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j - 1 + end do + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /val(j) + j = j - 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /val(j) + j = j + 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j + 1 + end do + end do + end if + end if + end if + + else if (ctra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /conjg(val(j)) + j = j - 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /conjg(val(j)) + j = j + 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j + 1 + end do + end do + end if + end if + end if + end if + end subroutine inner_coosm + +end subroutine psb_c_coo_cssm + + + +subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cssv + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_coo_cssv_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (alpha == zzero) then + if (beta == zzero) then + do i = 1, m + y(i) = zzero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + return + end if + + if (beta == zzero) then + call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& + & x,y,info) + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + do i = 1, m + y(i) = alpha*y(i) + end do + else + allocate(tmp(m), stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& + & x,tmp,info) + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + do i = 1, m + y(i) = alpha*tmp(i) + beta*y(i) + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& + & ia,ja,val,x,y,info) + implicit none + logical, intent(in) :: tra,ctra,lower,unit,sorted + integer, intent(in) :: nr,nz,ia(*),ja(*) + complex(psb_spk_), intent(in) :: val(*), x(*) + complex(psb_spk_), intent(out) :: y(*) + integer, intent(out) :: info + + integer :: i,j,k,m, ir, jc, nnz + complex(psb_spk_) :: acc + + info = psb_success_ + if (.not.sorted) then + info = psb_err_invalid_mat_state_ + return + end if + + nnz = nz + + if ((.not.tra).and.(.not.ctra)) then + + if (lower) then + if (unit) then + j = 1 + do i=1, nr + acc = zzero + do + if (j > nnz) exit + if (ia(j) > i) exit + acc = acc + val(j)*y(ja(j)) + j = j + 1 + end do + y(i) = x(i) - acc + end do + else if (.not.unit) then + j = 1 + do i=1, nr + acc = zzero + do + if (j > nnz) exit + if (ia(j) > i) exit + if (ja(j) == i) then + y(i) = (x(i) - acc)/val(j) + j = j + 1 + exit + end if + acc = acc + val(j)*y(ja(j)) + j = j + 1 + end do + end do + end if + + else if (.not.lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = zzero + do + if (j < 1) exit + if (ia(j) < i) exit + acc = acc + val(j)*y(ja(j)) + j = j - 1 + end do + y(i) = x(i) - acc + end do + + else if (.not.unit) then + + j = nnz + do i=nr, 1, -1 + acc = zzero + do + if (j < 1) exit + if (ia(j) < i) exit + if (ja(j) == i) then + y(i) = (x(i) - acc)/val(j) + j = j - 1 + exit + end if + acc = acc + val(j)*y(ja(j)) + j = j - 1 + end do + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i) = x(i) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i) = y(i) /val(j) + j = j - 1 + end if + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i) = y(i) /val(j) + j = j + 1 + end if + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j + 1 + end do + end do + end if + end if + end if + + else if (ctra) then + + do i=1, nr + y(i) = x(i) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i) = y(i) /conjg(val(j)) + j = j - 1 + end if + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i) = y(i) /conjg(val(j)) + j = j + 1 + end if + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + j = j + 1 + end do + end do + end if + end if + end if + end if + + end subroutine inner_coosv + + +end subroutine psb_c_coo_cssv + +subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csmv + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_spk_) :: acc + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_coo_csmv_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nnz = a%get_nzeros() + + if (alpha == zzero) then + if (beta == zzero) then + do i = 1, m + y(i) = zzero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + return + else + if (a%is_triangle().and.a%is_unit()) then + if (beta == zzero) then + do i = 1, min(m,n) + y(i) = alpha*x(i) + enddo + do i = min(m,n)+1, m + y(i) = zzero + enddo + else + do i = 1, min(m,n) + y(i) = beta*y(i) + alpha*x(i) + end do + do i = min(m,n)+1, m + y(i) = beta*y(i) + enddo + endif + else + if (beta == zzero) then + do i = 1, m + y(i) = zzero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + + endif + + end if + + if ((.not.tra).and.(.not.ctra)) then + i = 1 + j = i + if (nnz > 0) then + ir = a%ia(1) + acc = zzero + do + if (i>nnz) then + y(ir) = y(ir) + alpha * acc + exit + endif + if (a%ia(i) /= ir) then + y(ir) = y(ir) + alpha * acc + ir = a%ia(i) + acc = zzero + endif + acc = acc + a%val(i) * x(a%ja(i)) + i = i + 1 + enddo + end if + + else if (tra) then + + if (alpha == zone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + a%val(i)*x(jc) + enddo + + else if (alpha == -zone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) - a%val(i)*x(jc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + alpha*a%val(i)*x(jc) + enddo + + end if !.....end testing on alpha + + else if (ctra) then + + if (alpha == zone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + conjg(a%val(i))*x(jc) + enddo + + else if (alpha == -zone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) - conjg(a%val(i))*x(jc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + alpha*conjg(a%val(i))*x(jc) + enddo + + end if !.....end testing on alpha + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_csmv + + +subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csmm + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_), allocatable :: acc(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_coo_csmm_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + nnz = a%get_nzeros() + + nc = min(size(x,2), size(y,2)) + allocate(acc(nc),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + + if (alpha == zzero) then + if (beta == zzero) then + do i = 1, m + y(i,1:nc) = zzero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + return + else + if (a%is_triangle().and.a%is_unit()) then + if (beta == zzero) then + do i = 1, min(m,n) + y(i,1:nc) = alpha*x(i,1:nc) + enddo + do i = min(m,n)+1, m + y(i,1:nc) = zzero + enddo + else + do i = 1, min(m,n) + y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) + end do + do i = min(m,n)+1, m + y(i,1:nc) = beta*y(i,1:nc) + enddo + endif + else + if (beta == zzero) then + do i = 1, m + y(i,1:nc) = zzero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + + endif + + end if + + if ((.not.tra).and.(.not.ctra)) then + i = 1 + j = i + if (nnz > 0) then + ir = a%ia(1) + acc = zzero + do + if (i>nnz) then + y(ir,1:nc) = y(ir,1:nc) + alpha * acc + exit + endif + if (a%ia(i) /= ir) then + y(ir,1:nc) = y(ir,1:nc) + alpha * acc + ir = a%ia(i) + acc = zzero + endif + acc = acc + a%val(i) * x(a%ja(i),1:nc) + i = i + 1 + enddo + end if + + else if (tra) then + if (alpha == zone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + a%val(i)*x(jc,1:nc) + enddo + + else if (alpha == -zone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + alpha*a%val(i)*x(jc,1:nc) + enddo + + end if !.....end testing on alpha + + else if (ctra) then + + if (alpha == zone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + conjg(a%val(i))*x(jc,1:nc) + enddo + + else if (alpha == -zone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) - conjg(a%val(i))*x(jc,1:nc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + alpha*conjg(a%val(i))*x(jc,1:nc) + enddo + + end if !.....end testing on alpha + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_coo_csmm + +function psb_c_coo_csnmi(a) result(res) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csnmi + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='c_base_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + nnz = a%get_nzeros() + i = 1 + j = i + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + acc = dzero + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + +end function psb_c_coo_csnmi + + + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csgetptn + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_ibsrch(irw,nza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_ibsrch(lrw,nza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_c_coo_csgetptn + + +subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csgetrow + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_ibsrch(irw,nza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_ibsrch(lrw,nza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + val(nzin_) = a%val(i) + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + val(nzin_) = a%val(i) + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getrow + +end subroutine psb_c_coo_csgetrow + + +subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csput + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='c_coo_csput_impl' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + info = psb_success_ + call psb_erractionsave(err_act) + + if (nz < 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + isza = a%get_size() + endif + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + call c_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) then + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza,ia1(:),ia2(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_), intent(inout) :: aspk(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -91 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -92 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine c_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nc,nnz,dupl,ng, nr + integer :: debug_level, debug_unit + character(len=20) :: name='c_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + endif + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = i + return + end if + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine c_coo_srch_upd + +end subroutine psb_c_coo_csput + + +subroutine psb_c_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_coo + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act, nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + + + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_cp_coo_to_coo + +subroutine psb_c_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_coo + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_cp_coo_from_coo + + +subroutine psb_c_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_fmt + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_cp_coo_to_fmt + +subroutine psb_c_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_fmt + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_cp_coo_from_fmt + + +subroutine psb_c_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_to_coo + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_mv_coo_to_coo + +subroutine psb_c_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_from_coo + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_mv_coo_from_coo + + +subroutine psb_c_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_to_fmt + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_mv_coo_to_fmt + +subroutine psb_c_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_from_fmt + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_mv_coo_from_fmt + +subroutine psb_c_coo_cp_from(a,b) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cp_from + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + type(psb_c_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_coo_cp_from + +subroutine psb_c_coo_mv_from(a,b) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_mv_from + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_coo_mv_from + + + +subroutine psb_c_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_fix_coo + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + integer, allocatable :: iaux(:) + !locals + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + nza = a%get_nzeros() + if (nza < 2) return + + dupl_ = a%get_dupl() + + call psb_c_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + call a%set_sorted() + call a%set_nzeros(i) + call a%set_asb() + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_fix_coo + + + +subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + implicit none + + integer, intent(in) :: nzin, dupl + integer, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), intent(inout) :: val(:) + integer, intent(out) :: nzout, info + integer, intent(in), optional :: idir + !locals + integer, allocatable :: iaux(:) + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + + if (nzin < 2) return + + dupl_ = dupl + + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) return + + + select case(idir_) + + case(0) ! Row major order + + call msort_up(nzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + case(1) ! Col major order + + call msort_up(nzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine psb_c_fix_coo_inner + diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 new file mode 100644 index 00000000..326d6318 --- /dev/null +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -0,0 +1,3038 @@ +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + +subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csmv + implicit none + class(psb_c_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_spk_) :: acc + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_csc_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra.or.ctra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + + if (size(x,1) psb_c_csc_csmm + implicit none + class(psb_c_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_), allocatable :: acc(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_csc_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra.or.ctra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_c_csc_cssv + implicit none + class(psb_c_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_csc_cssv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + m = a%get_nrows() + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (size(x,1) psb_c_csc_cssm + implicit none + class(psb_c_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:,:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_base_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + m = a%get_nrows() + nc = min(size(x,2) , size(y,2)) + + if (size(x,1) psb_c_csc_csnmi + implicit none + class(psb_c_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer :: i,j,k,m,n, nr, ir, jc, nc, info + real(psb_spk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='c_csnmi' + logical, parameter :: debug=.false. + + + res = czero + nr = a%get_nrows() + nc = a%get_ncols() + allocate(acc(nr),stat=info) + if (info /= psb_success_) then + return + end if + acc(:) = dzero + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + acc(a%ia(j)) = acc(a%ia(j)) + abs(a%val(j)) + end do + end do + do i=1, nr + res = max(res,acc(i)) + end do + deallocate(acc) + +end function psb_c_csc_csnmi + + +subroutine psb_c_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_get_diag + implicit none + class(psb_c_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = cone + else + do i=1, mnm + d(i) = czero + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = czero + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_get_diag + + +subroutine psb_c_csc_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_scal + implicit none + class(psb_c_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, n + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, n + do j = a%icp(i), a%icp(i+1) -1 + a%val(j) = a%val(j) * d(a%ia(j)) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_scal + + +subroutine psb_c_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_scals + implicit none + class(psb_c_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_scals + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + +subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csgetptn + implicit none + + class(psb_c_csc_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + + end subroutine csc_getptn + +end subroutine psb_c_csc_csgetptn + + + + +subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csgetrow + implicit none + + class(psb_c_csc_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + call psb_ensure_size(int(1.25*nzin_)+1,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + call psb_ensure_size(int(1.25*nzin_)+1,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + end subroutine csc_getrow + +end subroutine psb_c_csc_csgetrow + + + +subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csput + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='c_csc_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_c_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= psb_success_) then + + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_c_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng, nar, nac + integer :: debug_level, debug_unit + character(len=20) :: name='c_csc_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nar = a%get_nrows() + nac = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + + else + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding col that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding col that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_c_csc_srch_upd + +end subroutine psb_c_csc_csput + + + +subroutine psb_c_cp_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_from_coo + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + type(psb_c_coo_sparse_mat) :: tmp + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_c_cp_csc_from_coo + + + +subroutine psb_c_cp_csc_to_coo(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_to_coo + implicit none + + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ia(j) = a%ia(j) + b%ja(j) = i + b%val(j) = a%val(j) + end do + end do + + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_c_cp_csc_to_coo + + +subroutine psb_c_mv_csc_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_to_coo + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ia,b%ia) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ja,info) + if (info /= psb_success_) return + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ja(j) = i + end do + end do + call a%free() + call b%fix(info) + +end subroutine psb_c_mv_csc_to_coo + + + +subroutine psb_c_mv_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_from_coo + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc, icl + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info, idir=1) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ja,itemp) + call move_alloc(b%ia,a%ia) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%icp,info) + call b%free() + + if (nza <= 0) then + a%icp(:) = 1 + else + a%icp(1) = 1 + if (nc < itemp(nza)) then + write(debug_unit,*) trim(name),': CLSHR=.false. : ',& + &nc,itemp(nza),' Expect trouble!' + info = 12 + end if + + j = 1 + i = 1 + icl = itemp(j) + + outer: do + inner: do + if (i >= icl) exit inner + if (i > nc) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nc,j,nza,icl,idl + exit outer + end if + a%icp(i+1) = a%icp(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= icl) then + a%icp(i+1) = j + icl = itemp(j) + i = i + 1 + endif + if (i > nc) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i > nc) exit + a%icp(i+1) = j + i = i + 1 + end do + + endif + + +end subroutine psb_c_mv_csc_from_coo + + +subroutine psb_c_mv_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_to_fmt + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_c_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_c_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_c_csc_sparse_mat) + call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call move_alloc(a%icp, b%icp) + call move_alloc(a%ia, b%ia) + call move_alloc(a%val, b%val) + call a%free() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_c_mv_csc_to_fmt +!!$ + +subroutine psb_c_cp_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_to_fmt + implicit none + + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_c_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_c_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_c_csc_sparse_mat) + call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + b%icp = a%icp + b%ia = a%ia + b%val = a%val + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_c_cp_csc_to_fmt + + +subroutine psb_c_mv_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_from_fmt + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_c_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_c_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_c_csc_sparse_mat) + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_c_mv_csc_from_fmt + + + +subroutine psb_c_cp_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_from_fmt + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + !locals + type(psb_c_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_c_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_c_csc_sparse_mat) + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_c_cp_csc_from_fmt + +subroutine psb_c_csc_mold(a,b,info) + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mold + use psb_error_mod + implicit none + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_c_csc_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csc_mold + +subroutine psb_c_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_c_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='c_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_reallocate_nz + + + +subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csgetblk + implicit none + + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_csgetblk + +subroutine psb_c_csc_reinit(a,clear) + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_reinit + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = czero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_reinit + +subroutine psb_c_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_trim + implicit none + class(psb_c_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, n + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + n = a%get_ncols() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_trim + +subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_c_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csc_allocate_mnnz + +subroutine psb_c_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_print + implicit none + + integer, intent(in) :: iout + class(psb_c_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='c_csc_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_c_csc_print + +subroutine psb_c_csc_cp_from(a,b) + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_cp_from + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + type(psb_c_csc_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = psb_success_ + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csc_cp_from + +subroutine psb_c_csc_mv_from(a,b) + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mv_from + implicit none + + class(psb_c_csc_sparse_mat), intent(inout) :: a + type(psb_c_csc_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csc_mv_from + + + diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 new file mode 100644 index 00000000..53b6381f --- /dev/null +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -0,0 +1,2848 @@ + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + +subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csmv + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_spk_) :: acc + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_csr_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_c_csr_csmm + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_), allocatable :: acc(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_csr_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_c_csr_cssv + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:) + logical :: tra,ctra + Integer :: err_act + character(len=20) :: name='c_csr_cssv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + m = a%get_nrows() + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (size(x) psb_c_csr_cssm + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:,:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='c_csr_cssm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + m = a%get_nrows() + nc = min(size(x,2) , size(y,2)) + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (alpha == dzero) then + if (beta == dzero) then + do i = 1, m + y(i,:) = dzero + enddo + else + do i = 1, m + y(i,:) = beta*y(i,:) + end do + endif + return + end if + + if (beta == dzero) then + call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info) + do i = 1, m + y(i,1:nc) = alpha*y(i,1:nc) + end do + else + allocate(tmp(m,nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info) + do i = 1, m + y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) + end do + end if + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='inner_csrsm') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine inner_csrsm(tra,ctra,lower,unit,nr,nc,& + & irp,ja,val,x,ldx,y,ldy,info) + implicit none + logical, intent(in) :: tra,ctra,lower,unit + integer, intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*) + complex(psb_spk_), intent(in) :: val(*), x(ldx,*) + complex(psb_spk_), intent(out) :: y(ldy,*) + integer, intent(out) :: info + integer :: i,j,k,m, ir, jc + complex(psb_spk_), allocatable :: acc(:) + + info = psb_success_ + allocate(acc(nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + + + if ((.not.tra).and.(.not.ctra)) then + if (lower) then + if (unit) then + do i=1, nr + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=1, nr + acc = dzero + do j=irp(i), irp(i+1)-2 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) + end do + end if + else if (.not.lower) then + + if (unit) then + do i=nr, 1, -1 + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=nr, 1, -1 + acc = dzero + do j=irp(i)+1, irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i)) + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + do i=nr, 1, -1 + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=nr, 1, -1 + y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, nr + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=1, nr + y(i,1:nc) = y(i,1:nc)/val(irp(i)) + acc = y(i,1:nc) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + + end if + + else if (ctra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + do i=nr, 1, -1 + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=nr, 1, -1 + y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i+1)-1)) + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, nr + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=1, nr + y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i))) + acc = y(i,1:nc) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + end if + + end if + end if + end subroutine inner_csrsm + +end subroutine psb_c_csr_cssm + +function psb_c_csr_csnmi(a) result(res) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csnmi + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer :: i,j,k,m,n, nr, ir, jc, nc + real(psb_spk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='c_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_c_csr_csnmi + +subroutine psb_c_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_get_diag + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = cone + else + do i=1, mnm + d(i) = czero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = czero + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_get_diag + + +subroutine psb_c_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_scal + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_scal + + +subroutine psb_c_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_scals + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_c_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_c_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='c_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_reallocate_nz + +subroutine psb_c_csr_mold(a,b,info) + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_mold + use psb_error_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_c_csr_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csr_mold + +subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_c_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_allocate_mnnz + + +subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csgetptn + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_c_csr_csgetrow + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_c_csr_csgetblk + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_csgetblk + + + +subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csput + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='c_csr_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + + call psb_erractionsave(err_act) + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_c_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= psb_success_) then + + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_c_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng + integer :: debug_level, debug_unit + character(len=20) :: name='c_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + + else + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_c_csr_srch_upd + +end subroutine psb_c_csr_csput + + +subroutine psb_c_csr_reinit(a,clear) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_reinit + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_reinit + +subroutine psb_c_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_trim + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csr_trim + +subroutine psb_c_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_print + implicit none + + integer, intent(in) :: iout + class(psb_c_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='c_csr_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_c_csr_print + + +subroutine psb_c_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_from_coo + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + type(psb_c_coo_sparse_mat) :: tmp + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_c_cp_csr_from_coo + + + +subroutine psb_c_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_to_coo + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_c_cp_csr_to_coo + + +subroutine psb_c_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_to_coo + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%fix(info) + + +end subroutine psb_c_mv_csr_to_coo + + + +subroutine psb_c_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_from_coo + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + if (nza <= 0) then + a%irp(:) = 1 + else + a%irp(1) = 1 + if (nr < itemp(nza)) then + write(debug_unit,*) trim(name),': RWSHR=.false. : ',& + &nr,itemp(nza),' Expect trouble!' + info = 12 + end if + + j = 1 + i = 1 + irw = itemp(j) + + outer: do + inner: do + if (i >= irw) exit inner + if (i>nr) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl + exit outer + end if + a%irp(i+1) = a%irp(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= irw) then + a%irp(i+1) = j + irw = itemp(j) + i = i + 1 + endif + if (i>nr) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i>nr) exit + a%irp(i+1) = j + i = i + 1 + end do + + endif + + +end subroutine psb_c_mv_csr_from_coo + + +subroutine psb_c_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_to_fmt + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_c_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_c_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_c_csr_sparse_mat) + call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_c_mv_csr_to_fmt + + +subroutine psb_c_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_to_fmt + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_c_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_c_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_c_csr_sparse_mat) + call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + b%irp = a%irp + b%ja = a%ja + b%val = a%val + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_c_cp_csr_to_fmt + + +subroutine psb_c_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_from_fmt + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_c_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_c_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_c_csr_sparse_mat) + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_c_mv_csr_from_fmt + + + +subroutine psb_c_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_from_fmt + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + !locals + type(psb_c_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nz, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_c_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_c_csr_sparse_mat) + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_c_cp_csr_from_fmt + + +subroutine psb_c_csr_cp_from(a,b) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_cp_from + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + type(psb_c_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = psb_success_ + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csr_cp_from + +subroutine psb_c_csr_mv_from(a,b) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_mv_from + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + type(psb_c_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csr_mv_from + + diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 new file mode 100644 index 00000000..f598148f --- /dev/null +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -0,0 +1,2004 @@ +! == =================================== +! +! +! +! Setters +! +! +! +! +! +! +! == =================================== + + +subroutine psb_c_set_nrows(m,a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_nrows + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_nrows + + +subroutine psb_c_set_ncols(n,a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_ncols + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_ncols + + + +subroutine psb_c_set_state(n,a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_state + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_state + + + +subroutine psb_c_set_dupl(n,a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_dupl + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_dupl + + +subroutine psb_c_set_null(a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_null + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_null + + +subroutine psb_c_set_bld(a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_bld + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_bld + + +subroutine psb_c_set_upd(a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_upd + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_c_set_upd + + +subroutine psb_c_set_asb(a) + use psb_c_mat_mod, psb_protect_name => psb_c_set_asb + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_asb + + +subroutine psb_c_set_sorted(a,val) + use psb_c_mat_mod, psb_protect_name => psb_c_set_sorted + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_sorted + + +subroutine psb_c_set_triangle(a,val) + use psb_c_mat_mod, psb_protect_name => psb_c_set_triangle + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_triangle + + +subroutine psb_c_set_unit(a,val) + use psb_c_mat_mod, psb_protect_name => psb_c_set_unit + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_unit + + +subroutine psb_c_set_lower(a,val) + use psb_c_mat_mod, psb_protect_name => psb_c_set_lower + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_lower + + +subroutine psb_c_set_upper(a,val) + use psb_c_mat_mod, psb_protect_name => psb_c_set_upper + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_c_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_c_mat_mod, psb_protect_name => psb_c_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_cspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 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,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_sparse_print + + + + +subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) + use psb_c_mat_mod, psb_protect_name => psb_c_get_neigh + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_get_neigh + + + +subroutine psb_c_csall(nr,nc,a,info,nz) + use psb_c_mat_mod, psb_protect_name => psb_c_csall + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = psb_success_ + allocate(psb_c_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 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csall + + +subroutine psb_c_reallocate_nz(nz,a) + use psb_c_mat_mod, psb_protect_name => psb_c_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_cspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_reallocate_nz + + +subroutine psb_c_free(a) + use psb_c_mat_mod, psb_protect_name => psb_c_free + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_c_free + + +subroutine psb_c_trim(a) + use psb_c_mat_mod, psb_protect_name => psb_c_trim + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_trim + + + +subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_mat_mod, psb_protect_name => psb_c_csput + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.a%is_bld()) 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_csput + + +subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csgetptn + implicit none + + class(psb_cspmat_type), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_csgetptn + + +subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csgetrow + implicit none + + class(psb_cspmat_type), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_csgetrow + + + + +subroutine psb_c_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csgetblk + implicit none + + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + + + info = 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%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_csgetblk + + + + +subroutine psb_c_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csclip + implicit none + + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + + info = 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%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_csclip + + +subroutine psb_c_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_b_csclip + implicit none + + class(psb_cspmat_type), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_b_csclip + + + + +subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cscnv + implicit none + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + + + class(psb_c_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 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 b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + +#if defined(HAVE_MOLD) + allocate(altmp, mold=mold,stat=info) +#else + call mold%mold(altmp,info) +#endif + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_c_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_c_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_c_csr_sparse_mat :: altmp, 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 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%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_cscnv + + + +subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cscnv_ip + implicit none + + class(psb_cspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + + + class(psb_c_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 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 + +#if defined(HAVE_MOLD) + allocate(altmp, mold=mold,stat=info) +#else + call mold%mold(altmp,info) +#endif + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_c_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_c_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_c_csr_sparse_mat :: altmp, 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_cscnv_ip + + + +subroutine psb_c_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cscnv_base + implicit none + class(psb_cspmat_type), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + + + type(psb_c_coo_sparse_mat) :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_cscnv_base + + + +subroutine psb_c_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_clip_d + implicit none + + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(out) :: b + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_clip_d + + + +subroutine psb_c_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_c_clip_d_ip + implicit none + + class(psb_cspmat_type), intent(inout) :: a + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_clip_d_ip + + +subroutine psb_c_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_mv_from + implicit none + class(psb_cspmat_type), intent(out) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer :: info + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b, stat=info) +#else + call b%mold(a%a,info) +#endif + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_c_mv_from + + +subroutine psb_c_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cp_from + implicit none + class(psb_cspmat_type), intent(out) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ +#else + call b%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine psb_c_cp_from + + +subroutine psb_c_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_mv_to + implicit none + class(psb_cspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_c_mv_to + + +subroutine psb_c_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cp_to + implicit none + class(psb_cspmat_type), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_c_cp_to + + + +subroutine psb_cspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_cspmat_type_move + implicit none + class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call move_alloc(a%a,b%a) + + return +end subroutine psb_cspmat_type_move + + +subroutine psb_cspmat_type_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_cspmat_type_clone + implicit none + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + +#if defined(HAVE_MOLD) + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ +#else + call a%a%mold(b%a,info) +#endif + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%a%cp_from_fmt(a%a, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_cspmat_type_clone + + + +subroutine psb_c_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_transp_1mat + implicit none + class(psb_cspmat_type), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_transp_1mat + + + +subroutine psb_c_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_transp_2mat + implicit none + class(psb_cspmat_type), intent(out) :: a + class(psb_cspmat_type), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b%a,stat=info) +#else + call b%a%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_transp_2mat + + +subroutine psb_c_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_transc_1mat + implicit none + class(psb_cspmat_type), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_transc_1mat + + + +subroutine psb_c_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_c_transc_2mat + implicit none + class(psb_cspmat_type), intent(out) :: a + class(psb_cspmat_type), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b%a,stat=info) +#else + call b%a%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_transc_2mat + + + + +subroutine psb_c_reinit(a,clear) + use psb_c_mat_mod, psb_protect_name => psb_c_reinit + use psb_error_mod + implicit none + + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_c_reinit + + + + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + + +subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csmm + implicit none + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 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%csmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csmm + + +subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_c_mat_mod, psb_protect_name => psb_c_csmv + implicit none + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 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%csmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_csmv + + +subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cssm + implicit none + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 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%cssm(alpha,x,beta,y,info,trans,scale,d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_cssm + + +subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cssv + implicit none + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 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%cssm(alpha,x,beta,y,info,trans,scale,d) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_cssv + + + +function psb_c_csnmi(a) result(res) + use psb_c_mat_mod, psb_protect_name => psb_c_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_cspmat_type), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_c_csnmi + + +subroutine psb_c_get_diag(a,d,info) + use psb_c_mat_mod, psb_protect_name => psb_c_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_get_diag + + +subroutine psb_c_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_scal + implicit none + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_scal + + +subroutine psb_c_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_scals + implicit none + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_scals + + + diff --git a/base/serial/impl/psb_d_base_mat_impl.f90 b/base/serial/impl/psb_d_base_mat_impl.f90 new file mode 100644 index 00000000..a6ad8394 --- /dev/null +++ b/base/serial/impl/psb_d_base_mat_impl.f90 @@ -0,0 +1,1236 @@ +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_d_base_cp_to_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_cp_to_coo + +subroutine psb_d_base_cp_from_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_cp_from_coo + + +subroutine psb_d_base_cp_to_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_cp_to_fmt + +subroutine psb_d_base_cp_from_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_cp_from_fmt + + +subroutine psb_d_base_mv_to_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_mv_to_coo + +subroutine psb_d_base_mv_from_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_mv_from_coo + + +subroutine psb_d_base_mv_to_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_mv_to_fmt + +subroutine psb_d_base_mv_from_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_mv_from_fmt + +subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_csput + +subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csgetrow + implicit none + + class(psb_d_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_csgetrow + + + +subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csgetblk + implicit none + + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_base_csgetblk + + +subroutine psb_d_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csclip + implicit none + + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_base_csclip + +subroutine psb_d_base_mold(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mold + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_mold + +subroutine psb_d_base_transp_2mat(a,b) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_d_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_d_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='d_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_d_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_transp_2mat + +subroutine psb_d_base_transc_2mat(a,b) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transc_2mat + implicit none + + class(psb_d_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transp(b) +end subroutine psb_d_base_transc_2mat + +subroutine psb_d_base_transp_1mat(a) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_d_base_sparse_mat), intent(inout) :: a + + type(psb_d_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='d_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_transp_1mat + +subroutine psb_d_base_transc_1mat(a) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transc_1mat + implicit none + + class(psb_d_base_sparse_mat), intent(inout) :: a + + call a%transp() +end subroutine psb_d_base_transc_1mat + + +! == ================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == ================================== + +subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csmm + use psb_error_mod + + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='d_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_csmm + + +subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csmv + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='d_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + +end subroutine psb_d_base_csmv + + +subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_inner_cssm + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='d_base_inner_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_inner_cssm + + +subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_inner_cssv + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='d_base_inner_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_inner_cssv + + +subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cssm + use psb_error_mod + use psb_string_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + + real(psb_dpk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='d_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == psb_success_)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else if (psb_toupper(scale_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& + & call a%inner_cssm(done,x,dzero,tmp,info,trans) + + if (info == psb_success_)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == psb_success_)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_d_base_cssm + + +subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cssv + use psb_error_mod + use psb_string_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + + real(psb_dpk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='d_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + if (info == psb_success_)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else if (psb_toupper(scale_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + if (beta == dzero) then + call a%inner_cssm(alpha,x,dzero,y,info,trans) + if (info == psb_success_) call inner_vscal1(nar,d,y) + else + allocate(tmp(nar),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& + & call a%inner_cssm(alpha,x,dzero,tmp,info,trans) + + if (info == psb_success_) call inner_vscal1(nar,d,tmp) + if (info == psb_success_)& + & call psb_geaxpby(nar,done,tmp,beta,y,info) + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +contains + subroutine inner_vscal(n,d,x,y) + implicit none + integer, intent(in) :: n + real(psb_dpk_), intent(in) :: d(*),x(*) + real(psb_dpk_), intent(out) :: y(*) + integer :: i + + do i=1,n + y(i) = d(i)*x(i) + end do + end subroutine inner_vscal + + + subroutine inner_vscal1(n,d,x) + implicit none + integer, intent(in) :: n + real(psb_dpk_), intent(in) :: d(*) + real(psb_dpk_), intent(inout) :: x(*) + integer :: i + + do i=1,n + x(i) = d(i)*x(i) + end do + end subroutine inner_vscal1 + +end subroutine psb_d_base_cssv + + +subroutine psb_d_base_scals(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_scals + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='d_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_scals + + + +subroutine psb_d_base_scal(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_scal + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='d_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_base_scal + + + +function psb_d_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csnmi + + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -done + + return + +end function psb_d_base_csnmi + +function psb_d_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csnm1 + + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -done + + return + +end function psb_d_base_csnm1 + +subroutine psb_d_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_rowsum + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + Integer :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_rowsum + +subroutine psb_d_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_arwsum + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + Integer :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_arwsum + +subroutine psb_d_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_colsum + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + Integer :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_colsum + +subroutine psb_d_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_aclsum + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + Integer :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_aclsum + + +subroutine psb_d_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_get_diag + + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_get_diag + + + + diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 new file mode 100644 index 00000000..8d22c396 --- /dev/null +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -0,0 +1,3280 @@ + +subroutine psb_d_coo_get_diag(a,d,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = dzero + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = done + else + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_get_diag + + +subroutine psb_d_coo_scal(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_scal + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_scal + + +subroutine psb_d_coo_scals(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_scals + + +subroutine psb_d_coo_reallocate_nz(nz,a) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_d_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='d_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_reallocate_nz + +subroutine psb_d_coo_mold(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_mold + use psb_error_mod + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_d_coo_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_coo_mold + + +subroutine psb_d_coo_reinit(a,clear) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_reinit + use psb_error_mod + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_reinit + + + +subroutine psb_d_coo_trim(a) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_trim + + +subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_d_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_allocate_mnnz + + + +subroutine psb_d_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_print + use psb_string_mod + implicit none + + integer, intent(in) :: iout + class(psb_d_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='d_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_d_coo_print + + + + +function psb_d_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_get_nz_row + implicit none + + class(psb_d_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_d_coo_get_nz_row + +subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cssm + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_base_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + nc = min(size(x,2) , size(y,2)) + nnz = a%get_nzeros() + + if (alpha == dzero) then + if (beta == dzero) then + do i = 1, m + y(i,1:nc) = dzero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + return + end if + + if (beta == dzero) then + call inner_coosm(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & m,nc,nnz,a%ia,a%ja,a%val,& + & x,size(x,1),y,size(y,1),info) + do i = 1, m + y(i,1:nc) = alpha*y(i,1:nc) + end do + else + allocate(tmp(m,nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_coosm(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & m,nc,nnz,a%ia,a%ja,a%val,& + & x,size(x,1),tmp,size(tmp,1),info) + do i = 1, m + y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) + end do + end if + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='inner_coosm') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine inner_coosm(tra,lower,unit,sorted,nr,nc,nz,& + & ia,ja,val,x,ldx,y,ldy,info) + implicit none + logical, intent(in) :: tra,lower,unit,sorted + integer, intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) + real(psb_dpk_), intent(in) :: val(*), x(ldx,*) + real(psb_dpk_), intent(out) :: y(ldy,*) + integer, intent(out) :: info + + integer :: i,j,k,m, ir, jc + real(psb_dpk_), allocatable :: acc(:) + + info = psb_success_ + allocate(acc(nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + + + if (.not.sorted) then + info = psb_err_invalid_mat_state_ + return + end if + + nnz = nz + + if (.not.tra) then + + if (lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = dzero + do + if (j > nnz) exit + if (ia(j) > i) exit + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j + 1 + end do + y(i,1:nc) = x(i,1:nc) - acc(1:nc) + end do + else if (.not.unit) then + j = 1 + do i=1, nr + acc(1:nc) = dzero + do + if (j > nnz) exit + if (ia(j) > i) exit + if (ja(j) == i) then + y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) + j = j + 1 + exit + end if + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j + 1 + end do + end do + end if + + else if (.not.lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = dzero + do + if (j < 1) exit + if (ia(j) < i) exit + acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) + j = j - 1 + end do + y(i,1:nc) = x(i,1:nc) - acc(1:nc) + end do + + else if (.not.unit) then + + j = nnz + do i=nr, 1, -1 + acc(1:nc) = dzero + do + if (j < 1) exit + if (ia(j) < i) exit + if (ja(j) == i) then + y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) + j = j - 1 + exit + end if + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j - 1 + end do + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /val(j) + j = j - 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /val(j) + j = j + 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j + 1 + end do + end do + end if + end if + end if + end if + end subroutine inner_coosm + +end subroutine psb_d_coo_cssm + + + +subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cssv + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_coo_cssv_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (alpha == dzero) then + if (beta == dzero) then + do i = 1, m + y(i) = dzero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + return + end if + + if (beta == dzero) then + call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& + & x,y,info) + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + do i = 1, m + y(i) = alpha*y(i) + end do + else + allocate(tmp(m), stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& + & x,tmp,info) + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + do i = 1, m + y(i) = alpha*tmp(i) + beta*y(i) + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + subroutine inner_coosv(tra,lower,unit,sorted,nr,nz,& + & ia,ja,val,x,y,info) + implicit none + logical, intent(in) :: tra,lower,unit,sorted + integer, intent(in) :: nr,nz,ia(*),ja(*) + real(psb_dpk_), intent(in) :: val(*), x(*) + real(psb_dpk_), intent(out) :: y(*) + integer, intent(out) :: info + + integer :: i,j,k,m, ir, jc, nnz + real(psb_dpk_) :: acc + + info = psb_success_ + if (.not.sorted) then + info = psb_err_invalid_mat_state_ + return + end if + + nnz = nz + + if (.not.tra) then + + if (lower) then + if (unit) then + j = 1 + do i=1, nr + acc = dzero + do + if (j > nnz) exit + if (ia(j) > i) exit + acc = acc + val(j)*y(ja(j)) + j = j + 1 + end do + y(i) = x(i) - acc + end do + else if (.not.unit) then + j = 1 + do i=1, nr + acc = dzero + do + if (j > nnz) exit + if (ia(j) > i) exit + if (ja(j) == i) then + y(i) = (x(i) - acc)/val(j) + j = j + 1 + exit + end if + acc = acc + val(j)*y(ja(j)) + j = j + 1 + end do + end do + end if + + else if (.not.lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = dzero + do + if (j < 1) exit + if (ia(j) < i) exit + acc = acc + val(j)*y(ja(j)) + j = j - 1 + end do + y(i) = x(i) - acc + end do + + else if (.not.unit) then + + j = nnz + do i=nr, 1, -1 + acc = dzero + do + if (j < 1) exit + if (ia(j) < i) exit + if (ja(j) == i) then + y(i) = (x(i) - acc)/val(j) + j = j - 1 + exit + end if + acc = acc + val(j)*y(ja(j)) + j = j - 1 + end do + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i) = x(i) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i) = y(i) /val(j) + j = j - 1 + end if + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i) = y(i) /val(j) + j = j + 1 + end if + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j + 1 + end do + end do + end if + end if + end if + end if + + end subroutine inner_coosv + + +end subroutine psb_d_coo_cssv + +subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csmv + implicit none + + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_dpk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='d_coo_csmv_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nnz = a%get_nzeros() + + if (alpha == dzero) then + if (beta == dzero) then + do i = 1, m + y(i) = dzero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + return + else + if (a%is_triangle().and.a%is_unit()) then + if (beta == dzero) then + do i = 1, min(m,n) + y(i) = alpha*x(i) + enddo + do i = min(m,n)+1, m + y(i) = dzero + enddo + else + do i = 1, min(m,n) + y(i) = beta*y(i) + alpha*x(i) + end do + do i = min(m,n)+1, m + y(i) = beta*y(i) + enddo + endif + else + if (beta == dzero) then + do i = 1, m + y(i) = dzero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + + endif + + end if + + if (.not.tra) then + i = 1 + j = i + if (nnz > 0) then + ir = a%ia(1) + acc = dzero + do + if (i>nnz) then + y(ir) = y(ir) + alpha * acc + exit + endif + if (a%ia(i) /= ir) then + y(ir) = y(ir) + alpha * acc + ir = a%ia(i) + acc = dzero + endif + acc = acc + a%val(i) * x(a%ja(i)) + i = i + 1 + enddo + end if + + else if (tra) then + + if (alpha == done) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + a%val(i)*x(jc) + enddo + + else if (alpha == -done) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) - a%val(i)*x(jc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + alpha*a%val(i)*x(jc) + enddo + + end if !.....end testing on alpha + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_csmv + + +subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csmm + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_coo_csmm_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + nnz = a%get_nzeros() + + nc = min(size(x,2), size(y,2)) + allocate(acc(nc),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + + if (alpha == dzero) then + if (beta == dzero) then + do i = 1, m + y(i,1:nc) = dzero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + return + else + if (a%is_triangle().and.a%is_unit()) then + if (beta == dzero) then + do i = 1, min(m,n) + y(i,1:nc) = alpha*x(i,1:nc) + enddo + do i = min(m,n)+1, m + y(i,1:nc) = dzero + enddo + else + do i = 1, min(m,n) + y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) + end do + do i = min(m,n)+1, m + y(i,1:nc) = beta*y(i,1:nc) + enddo + endif + else + if (beta == dzero) then + do i = 1, m + y(i,1:nc) = dzero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + + endif + + end if + + if (.not.tra) then + i = 1 + j = i + if (nnz > 0) then + ir = a%ia(1) + acc = dzero + do + if (i>nnz) then + y(ir,1:nc) = y(ir,1:nc) + alpha * acc + exit + endif + if (a%ia(i) /= ir) then + y(ir,1:nc) = y(ir,1:nc) + alpha * acc + ir = a%ia(i) + acc = dzero + endif + acc = acc + a%val(i) * x(a%ja(i),1:nc) + i = i + 1 + enddo + end if + + else if (tra) then + if (alpha == done) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + a%val(i)*x(jc,1:nc) + enddo + + else if (alpha == -done) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + alpha*a%val(i)*x(jc,1:nc) + enddo + + end if !.....end testing on alpha + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_csmm + +function psb_d_coo_csnmi(a) result(res) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csnmi + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_coo_csnmi' + logical, parameter :: debug=.false. + + + res = -done + nnz = a%get_nzeros() + if (a%is_sorted()) then + i = 1 + j = i + res = dzero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + acc = dzero + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + vt(:) = dzero + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_d_coo_csnmi + + +function psb_d_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csnm1 + + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_coo_csnm1' + logical, parameter :: debug=.false. + + + res = -done + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + vt(:) = dzero + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_d_coo_csnm1 + +subroutine psb_d_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_rowsum + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_rowsum + +subroutine psb_d_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_arwsum + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_arwsum + +subroutine psb_d_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_colsum + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_colsum + +subroutine psb_d_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_aclsum + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_coo_aclsum + + + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csgetptn + implicit none + + class(psb_d_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_ibsrch(irw,nza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_ibsrch(lrw,nza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_d_coo_csgetptn + + +subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csgetrow + implicit none + + class(psb_d_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_ibsrch(irw,nza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_ibsrch(lrw,nza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + val(nzin_) = a%val(i) + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + val(nzin_) = a%val(i) + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getrow + +end subroutine psb_d_coo_csgetrow + + +subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csput + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='d_coo_csput_impl' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + info = psb_success_ + call psb_erractionsave(err_act) + + if (nz < 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + isza = a%get_size() + endif + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + call d_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) then + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza,ia1(:),ia2(:) + real(psb_dpk_), intent(in) :: val(:) + real(psb_dpk_), intent(inout) :: aspk(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -91 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -92 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine d_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + real(psb_dpk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nc,nnz,dupl,ng, nr + integer :: debug_level, debug_unit + character(len=20) :: name='d_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + endif + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = i + return + end if + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine d_coo_srch_upd + +end subroutine psb_d_coo_csput + + +subroutine psb_d_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_coo + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act, nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cp_coo_to_coo + +subroutine psb_d_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_coo + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cp_coo_from_coo + + +subroutine psb_d_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_fmt + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cp_coo_to_fmt + +subroutine psb_d_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_fmt + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_cp_coo_from_fmt + + +subroutine psb_d_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_to_coo + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_mv_coo_to_coo + +subroutine psb_d_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_from_coo + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_mv_coo_from_coo + + +subroutine psb_d_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_to_fmt + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_mv_coo_to_fmt + +subroutine psb_d_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_from_fmt + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_mv_coo_from_fmt + +subroutine psb_d_coo_cp_from(a,b) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cp_from + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + type(psb_d_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_coo_cp_from + +subroutine psb_d_coo_mv_from(a,b) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_mv_from + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_coo_mv_from + + + +subroutine psb_d_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_fix_coo + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + integer, allocatable :: iaux(:) + !locals + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + nza = a%get_nzeros() + if (nza < 2) return + + dupl_ = a%get_dupl() + + call psb_d_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + call a%set_sorted() + call a%set_nzeros(i) + call a%set_asb() + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_fix_coo + + + +subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + implicit none + + integer, intent(in) :: nzin, dupl + integer, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), intent(inout) :: val(:) + integer, intent(out) :: nzout, info + integer, intent(in), optional :: idir + !locals + integer, allocatable :: iaux(:) + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + + if (nzin < 2) return + + dupl_ = dupl + + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) return + + + select case(idir_) + + case(0) ! Row major order + + call msort_up(nzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + case(1) ! Col major order + + call msort_up(nzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine psb_d_fix_coo_inner + diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 new file mode 100644 index 00000000..9456db1b --- /dev/null +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -0,0 +1,2911 @@ + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + +subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csmv + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_dpk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csc_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + + if (size(x,1) psb_d_csc_csmm + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csc_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_d_csc_cssv + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csc_cssv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (size(x,1) psb_d_csc_cssm + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_base_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + + if (size(x,1) psb_d_csc_csnmi + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nr, ir, jc, nc, info + real(psb_dpk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + nr = a%get_nrows() + nc = a%get_ncols() + allocate(acc(nr),stat=info) + if (info /= psb_success_) then + return + end if + acc(:) = dzero + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + acc(a%ia(j)) = acc(a%ia(j)) + abs(a%val(j)) + end do + end do + do i=1, nr + res = max(res,acc(i)) + end do + deallocate(acc) + +end function psb_d_csc_csnmi + + +function psb_d_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csnm1 + + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csc_csnm1' + logical, parameter :: debug=.false. + + + res = dzero + m = a%get_nrows() + n = a%get_ncols() + do j=1, n + acc = dzero + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_d_csc_csnm1 + +subroutine psb_d_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_colsum + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + do i = 1, a%get_ncols() + d(i) = dzero + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_colsum + +subroutine psb_d_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_aclsum + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + + do i = 1, a%get_ncols() + d(i) = dzero + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_aclsum + +subroutine psb_d_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_rowsum + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_rowsum + +subroutine psb_d_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_arwsum + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_arwsum + + +subroutine psb_d_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_get_diag + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = done + else + do i=1, mnm + d(i) = dzero + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + endif + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_get_diag + + +subroutine psb_d_csc_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_scal + implicit none + class(psb_d_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, n + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, n + do j = a%icp(i), a%icp(i+1) -1 + a%val(j) = a%val(j) * d(a%ia(j)) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_scal + + +subroutine psb_d_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_scals + implicit none + class(psb_d_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_scals + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + +subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csgetptn + implicit none + + class(psb_d_csc_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + + end subroutine csc_getptn + +end subroutine psb_d_csc_csgetptn + + + + +subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csgetrow + implicit none + + class(psb_d_csc_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + call psb_ensure_size(int(1.25*nzin_)+1,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + call psb_ensure_size(int(1.25*nzin_)+1,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + end subroutine csc_getrow + +end subroutine psb_d_csc_csgetrow + + + +subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csput + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='d_csc_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_d_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= psb_success_) then + + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_d_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + real(psb_dpk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng, nar, nac + integer :: debug_level, debug_unit + character(len=20) :: name='d_csc_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nar = a%get_nrows() + nac = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + + else + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding col that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding col that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_d_csc_srch_upd + +end subroutine psb_d_csc_csput + + + +subroutine psb_d_cp_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_from_coo + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + type(psb_d_coo_sparse_mat) :: tmp + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_d_cp_csc_from_coo + + + +subroutine psb_d_cp_csc_to_coo(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_to_coo + implicit none + + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ia(j) = a%ia(j) + b%ja(j) = i + b%val(j) = a%val(j) + end do + end do + + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_d_cp_csc_to_coo + + +subroutine psb_d_mv_csc_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_to_coo + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ia,b%ia) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ja,info) + if (info /= psb_success_) return + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ja(j) = i + end do + end do + call a%free() + call b%fix(info) + +end subroutine psb_d_mv_csc_to_coo + + + +subroutine psb_d_mv_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_from_coo + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc, icl + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info, idir=1) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ja,itemp) + call move_alloc(b%ia,a%ia) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%icp,info) + call b%free() + + if (nza <= 0) then + a%icp(:) = 1 + else + a%icp(1) = 1 + if (nc < itemp(nza)) then + write(debug_unit,*) trim(name),': CLSHR=.false. : ',& + &nc,itemp(nza),' Expect trouble!' + info = 12 + end if + + j = 1 + i = 1 + icl = itemp(j) + + outer: do + inner: do + if (i >= icl) exit inner + if (i > nc) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nc,j,nza,icl,idl + exit outer + end if + a%icp(i+1) = a%icp(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= icl) then + a%icp(i+1) = j + icl = itemp(j) + i = i + 1 + endif + if (i > nc) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i > nc) exit + a%icp(i+1) = j + i = i + 1 + end do + + endif + + +end subroutine psb_d_mv_csc_from_coo + + +subroutine psb_d_mv_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_to_fmt + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_d_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_d_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_d_csc_sparse_mat) + call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call move_alloc(a%icp, b%icp) + call move_alloc(a%ia, b%ia) + call move_alloc(a%val, b%val) + call a%free() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_d_mv_csc_to_fmt +!!$ + +subroutine psb_d_cp_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_to_fmt + implicit none + + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_d_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_d_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_d_csc_sparse_mat) + call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + b%icp = a%icp + b%ia = a%ia + b%val = a%val + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_d_cp_csc_to_fmt + + +subroutine psb_d_mv_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_from_fmt + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_d_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_d_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_d_csc_sparse_mat) + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_d_mv_csc_from_fmt + + + +subroutine psb_d_cp_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_from_fmt + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + !locals + type(psb_d_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_d_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_d_csc_sparse_mat) + call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_d_cp_csc_from_fmt + +subroutine psb_d_csc_mold(a,b,info) + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mold + use psb_error_mod + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_d_csc_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csc_mold + + +subroutine psb_d_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_d_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='d_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_reallocate_nz + + + +subroutine psb_d_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csgetblk + implicit none + + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_csgetblk + +subroutine psb_d_csc_reinit(a,clear) + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_reinit + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_reinit + +subroutine psb_d_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_trim + implicit none + class(psb_d_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, n + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + n = a%get_ncols() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_trim + +subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_d_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csc_allocate_mnnz + +subroutine psb_d_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_print + implicit none + + integer, intent(in) :: iout + class(psb_d_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='d_csc_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_d_csc_print + +subroutine psb_d_csc_cp_from(a,b) + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_cp_from + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + type(psb_d_csc_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = psb_success_ + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csc_cp_from + +subroutine psb_d_csc_mv_from(a,b) + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mv_from + implicit none + + class(psb_d_csc_sparse_mat), intent(inout) :: a + type(psb_d_csc_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csc_mv_from + + + diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 new file mode 100644 index 00000000..b779f5b0 --- /dev/null +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -0,0 +1,2898 @@ + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + +subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csmv + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_dpk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csr_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_d_csr_csmm + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csr_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_d_csr_cssv + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csr_cssv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (size(x) psb_d_csr_cssm + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csr_cssm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + m = a%get_nrows() + nc = min(size(x,2) , size(y,2)) + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (alpha == dzero) then + if (beta == dzero) then + do i = 1, m + y(i,:) = dzero + enddo + else + do i = 1, m + y(i,:) = beta*y(i,:) + end do + endif + return + end if + + if (beta == dzero) then + call inner_csrsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info) + do i = 1, m + y(i,1:nc) = alpha*y(i,1:nc) + end do + else + allocate(tmp(m,nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_csrsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info) + do i = 1, m + y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) + end do + end if + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='inner_csrsm') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine inner_csrsm(tra,lower,unit,nr,nc,& + & irp,ja,val,x,ldx,y,ldy,info) + implicit none + logical, intent(in) :: tra,lower,unit + integer, intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*) + real(psb_dpk_), intent(in) :: val(*), x(ldx,*) + real(psb_dpk_), intent(out) :: y(ldy,*) + integer, intent(out) :: info + integer :: i,j,k,m, ir, jc + real(psb_dpk_), allocatable :: acc(:) + + info = psb_success_ + allocate(acc(nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + + + if (.not.tra) then + + if (lower) then + if (unit) then + do i=1, nr + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=1, nr + acc = dzero + do j=irp(i), irp(i+1)-2 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) + end do + end if + else if (.not.lower) then + + if (unit) then + do i=nr, 1, -1 + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=nr, 1, -1 + acc = dzero + do j=irp(i)+1, irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i)) + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + do i=nr, 1, -1 + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=nr, 1, -1 + y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, nr + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=1, nr + y(i,1:nc) = y(i,1:nc)/val(irp(i)) + acc = y(i,1:nc) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + + end if + end if + end subroutine inner_csrsm + +end subroutine psb_d_csr_cssm + +function psb_d_csr_csnmi(a) result(res) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csnmi + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nr, ir, jc, nc + real(psb_dpk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_d_csr_csnmi + + +function psb_d_csr_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csnm1 + + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='d_csr_csnm1' + logical, parameter :: debug=.false. + + + res = -done + nnz = a%get_nzeros() + m = a%get_nrows() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + vt(:) = dzero + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + vt(k) = vt(k) + abs(a%val(j)) + end do + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_d_csr_csnm1 + +subroutine psb_d_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_rowsum + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_rowsum + +subroutine psb_d_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_arwsum + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = m + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_arwsum + +subroutine psb_d_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_colsum + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_colsum + +subroutine psb_d_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_aclsum + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + Integer :: err_act, info, int_err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + int_err(1) = 1 + int_err(2) = size(d) + int_err(3) = n + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + end do + + return + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_aclsum + + +subroutine psb_d_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_get_diag + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = done + else + do i=1, mnm + d(i) = dzero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_get_diag + + +subroutine psb_d_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scal + implicit none + class(psb_d_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_scal + + +subroutine psb_d_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scals + implicit none + class(psb_d_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_d_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_d_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='d_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_reallocate_nz + +subroutine psb_d_csr_mold(a,b,info) + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mold + use psb_error_mod + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_d_csr_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csr_mold + +subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_d_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp = 0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_allocate_mnnz + + +subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csgetptn + implicit none + + class(psb_d_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_d_csr_csgetrow + implicit none + + class(psb_d_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_d_csr_csgetblk + implicit none + + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_csgetblk + + + +subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='d_csr_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + + call psb_erractionsave(err_act) + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_d_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= psb_success_) then + + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_d_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + real(psb_dpk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng + integer :: debug_level, debug_unit + character(len=20) :: name='d_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + + else + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_d_csr_srch_upd + +end subroutine psb_d_csr_csput + + +subroutine psb_d_csr_reinit(a,clear) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_reinit + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_reinit + +subroutine psb_d_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_trim + implicit none + class(psb_d_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csr_trim + +subroutine psb_d_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_print + implicit none + + integer, intent(in) :: iout + class(psb_d_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='d_csr_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_d_csr_print + + +subroutine psb_d_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_coo + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + type(psb_d_coo_sparse_mat) :: tmp + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! This is to have fix_coo called behind the scenes + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_d_cp_csr_from_coo + + + +subroutine psb_d_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_to_coo + implicit none + + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_d_cp_csr_to_coo + + +subroutine psb_d_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_to_coo + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%fix(info) + + +end subroutine psb_d_mv_csr_to_coo + + + +subroutine psb_d_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_from_coo + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info) + if (info /= psb_success_) return + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + + call b%free() + if (info /= psb_success_) return + if (nza <= 0) then + a%irp(:) = 1 + else + a%irp(1) = 1 + if (nr < itemp(nza)) then + write(debug_unit,*) trim(name),': RWSHR=.false. : ',& + &nr,itemp(nza),' Expect trouble!' + info = 12 + end if + + j = 1 + i = 1 + irw = itemp(j) + + outer: do + inner: do + if (i >= irw) exit inner + if (i>nr) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl + exit outer + end if + a%irp(i+1) = a%irp(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= irw) then + a%irp(i+1) = j + irw = itemp(j) + i = i + 1 + endif + if (i>nr) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i>nr) exit + a%irp(i+1) = j + i = i + 1 + end do + + endif + + +end subroutine psb_d_mv_csr_from_coo + + +subroutine psb_d_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_to_fmt + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_d_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_d_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_d_csr_sparse_mat) + call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_d_mv_csr_to_fmt + + +subroutine psb_d_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_to_fmt + implicit none + + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_d_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_d_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_d_csr_sparse_mat) + call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + call psb_safe_cpy( a%irp, b%irp , info) + call psb_safe_cpy( a%ja , b%ja , info) + call psb_safe_cpy( a%val, b%val , info) + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_d_cp_csr_to_fmt + + +subroutine psb_d_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_from_fmt + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_d_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_d_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_d_csr_sparse_mat) + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_d_mv_csr_from_fmt + + + +subroutine psb_d_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_fmt + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + !locals + type(psb_d_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nz, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_d_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_d_csr_sparse_mat) + call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + call psb_safe_cpy( b%irp, a%irp , info) + call psb_safe_cpy( b%ja , a%ja , info) + call psb_safe_cpy( b%val, a%val , info) + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_d_cp_csr_from_fmt + + +subroutine psb_d_csr_cp_from(a,b) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cp_from + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + type(psb_d_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = psb_success_ + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csr_cp_from + +subroutine psb_d_csr_mv_from(a,b) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mv_from + implicit none + + class(psb_d_csr_sparse_mat), intent(inout) :: a + type(psb_d_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csr_mv_from + + diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 new file mode 100644 index 00000000..883eb136 --- /dev/null +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -0,0 +1,2238 @@ +! == =================================== +! +! +! +! Setters +! +! +! +! +! +! +! == =================================== + + +subroutine psb_d_set_nrows(m,a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_nrows + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_nrows + + +subroutine psb_d_set_ncols(n,a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_ncols + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_ncols + + + +subroutine psb_d_set_state(n,a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_state + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_state + + + +subroutine psb_d_set_dupl(n,a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_dupl + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_dupl + + +subroutine psb_d_set_null(a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_null + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_null + + +subroutine psb_d_set_bld(a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_bld + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_bld + + +subroutine psb_d_set_upd(a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_upd + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_d_set_upd + + +subroutine psb_d_set_asb(a) + use psb_d_mat_mod, psb_protect_name => psb_d_set_asb + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_asb + + +subroutine psb_d_set_sorted(a,val) + use psb_d_mat_mod, psb_protect_name => psb_d_set_sorted + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_sorted + + +subroutine psb_d_set_triangle(a,val) + use psb_d_mat_mod, psb_protect_name => psb_d_set_triangle + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_triangle + + +subroutine psb_d_set_unit(a,val) + use psb_d_mat_mod, psb_protect_name => psb_d_set_unit + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_unit + + +subroutine psb_d_set_lower(a,val) + use psb_d_mat_mod, psb_protect_name => psb_d_set_lower + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_lower + + +subroutine psb_d_set_upper(a,val) + use psb_d_mat_mod, psb_protect_name => psb_d_set_upper + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_d_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_d_mat_mod, psb_protect_name => psb_d_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_dspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 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,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_sparse_print + +subroutine psb_d_n_sparse_print(fname,a,iv,eirs,eics,head,ivr,ivc) + use psb_d_mat_mod, psb_protect_name => psb_d_n_sparse_print + use psb_error_mod + implicit none + + character(len=*), intent(in) :: fname + class(psb_dspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info, 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,eirs,eics,head,ivr,ivc) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_n_sparse_print + + + + +subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) + use psb_d_mat_mod, psb_protect_name => psb_d_get_neigh + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_get_neigh + + + +subroutine psb_d_csall(nr,nc,a,info,nz) + use psb_d_mat_mod, psb_protect_name => psb_d_csall + use psb_d_base_mat_mod + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = psb_success_ + allocate(psb_d_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 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csall + + +subroutine psb_d_reallocate_nz(nz,a) + use psb_d_mat_mod, psb_protect_name => psb_d_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_dspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_reallocate_nz + + +subroutine psb_d_free(a) + use psb_d_mat_mod, psb_protect_name => psb_d_free + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_d_free + + +subroutine psb_d_trim(a) + use psb_d_mat_mod, psb_protect_name => psb_d_trim + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_trim + + + +subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_d_mat_mod, psb_protect_name => psb_d_csput + use psb_d_base_mat_mod + use psb_error_mod + implicit none + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.a%is_bld()) 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_csput + + +subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csgetptn + implicit none + + class(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_csgetptn + + +subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csgetrow + implicit none + + class(psb_dspmat_type), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_csgetrow + + + + +subroutine psb_d_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csgetblk + implicit none + + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat), allocatable :: acoo + + + info = 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%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_csgetblk + + + + +subroutine psb_d_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csclip + implicit none + + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat), allocatable :: acoo + + info = 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%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_csclip + + +subroutine psb_d_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_b_csclip + implicit none + + class(psb_dspmat_type), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_b_csclip + + + + +subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cscnv + implicit none + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + + + class(psb_d_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 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 b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + +#if defined(HAVE_MOLD) + allocate(altmp, mold=mold,stat=info) +#else + call mold%mold(altmp,info) +#endif + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_d_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_d_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_d_csr_sparse_mat :: altmp, 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 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%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_cscnv + + + +subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cscnv_ip + implicit none + + class(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + + + class(psb_d_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 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 + +#if defined(HAVE_MOLD) + allocate(altmp, mold=mold,stat=info) +#else + call mold%mold(altmp,info) +#endif + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_d_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_d_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_d_csr_sparse_mat :: altmp, 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_cscnv_ip + + + +subroutine psb_d_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cscnv_base + implicit none + class(psb_dspmat_type), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + + + type(psb_d_coo_sparse_mat) :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_cscnv_base + + + +subroutine psb_d_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_clip_d + implicit none + + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(out) :: b + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_clip_d + + + +subroutine psb_d_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_d_clip_d_ip + implicit none + + class(psb_dspmat_type), intent(inout) :: a + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_clip_d_ip + + +subroutine psb_d_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_mv_from + implicit none + class(psb_dspmat_type), intent(out) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer :: info + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b, stat=info) +#else + call b%mold(a%a,info) +#endif + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_d_mv_from + + +subroutine psb_d_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cp_from + implicit none + class(psb_dspmat_type), intent(out) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ +#else + call b%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine psb_d_cp_from + + +subroutine psb_d_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_mv_to + implicit none + class(psb_dspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + integer :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_d_mv_to + + +subroutine psb_d_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cp_to + implicit none + class(psb_dspmat_type), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + integer :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_d_cp_to + + + +subroutine psb_dspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_dspmat_type_move + implicit none + class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call move_alloc(a%a,b%a) + + return +end subroutine psb_dspmat_type_move + + +subroutine psb_dspmat_type_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_dspmat_type_clone + implicit none + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + +#if defined(HAVE_MOLD) + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ +#else + call a%a%mold(b%a,info) +#endif + if (info == psb_success_) call b%a%cp_from_fmt(a%a, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_dspmat_type_clone + + + +subroutine psb_d_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_transp_1mat + implicit none + class(psb_dspmat_type), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_transp_1mat + + + +subroutine psb_d_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_transp_2mat + implicit none + class(psb_dspmat_type), intent(out) :: a + class(psb_dspmat_type), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b%a,stat=info) +#else + call b%a%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_transp_2mat + + +subroutine psb_d_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_transc_1mat + implicit none + class(psb_dspmat_type), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_transc_1mat + + + +subroutine psb_d_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_d_transc_2mat + implicit none + class(psb_dspmat_type), intent(out) :: a + class(psb_dspmat_type), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b%a,stat=info) +#else + call b%a%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_transc_2mat + + + + +subroutine psb_d_reinit(a,clear) + use psb_d_mat_mod, psb_protect_name => psb_d_reinit + use psb_error_mod + implicit none + + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_d_reinit + + + + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + + +subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csmm + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 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%csmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csmm + + +subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_d_mat_mod, psb_protect_name => psb_d_csmv + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 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%csmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_csmv + + +subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cssm + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 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%cssm(alpha,x,beta,y,info,trans,scale,d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cssm + + +subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cssv + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 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%cssm(alpha,x,beta,y,info,trans,scale,d) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_cssv + + + +function psb_d_csnmi(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_d_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_d_csnmi + + +function psb_d_csnm1(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_d_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnm1' + 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 + + res = a%a%csnm1() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_d_csnm1 + + +subroutine psb_d_rowsum(d,a,info) + use psb_d_mat_mod, psb_protect_name => psb_d_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='rowsum' + 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%rowsum(d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_rowsum + +subroutine psb_d_arwsum(d,a,info) + use psb_d_mat_mod, psb_protect_name => psb_d_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='arwsum' + 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%arwsum(d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_arwsum + +subroutine psb_d_colsum(d,a,info) + use psb_d_mat_mod, psb_protect_name => psb_d_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='colsum' + 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%colsum(d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_colsum + +subroutine psb_d_aclsum(d,a,info) + use psb_d_mat_mod, psb_protect_name => psb_d_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='aclsum' + 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%aclsum(d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_aclsum + +subroutine psb_d_get_diag(a,d,info) + use psb_d_mat_mod, psb_protect_name => psb_d_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_get_diag + + +subroutine psb_d_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_scal + implicit none + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_scal + + +subroutine psb_d_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_scals + implicit none + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_scals + + + diff --git a/base/serial/impl/psb_s_base_mat_impl.f90 b/base/serial/impl/psb_s_base_mat_impl.f90 new file mode 100644 index 00000000..e6ad064e --- /dev/null +++ b/base/serial/impl/psb_s_base_mat_impl.f90 @@ -0,0 +1,1102 @@ +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_s_base_cp_to_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_cp_to_coo + +subroutine psb_s_base_cp_from_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_cp_from_coo + + +subroutine psb_s_base_cp_to_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_cp_to_fmt + +subroutine psb_s_base_cp_from_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_cp_from_fmt + + +subroutine psb_s_base_mv_to_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_mv_to_coo + +subroutine psb_s_base_mv_from_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_mv_from_coo + + +subroutine psb_s_base_mv_to_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_mv_to_fmt + +subroutine psb_s_base_mv_from_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_mv_from_fmt + +subroutine psb_s_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_csput + +subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csgetrow + implicit none + + class(psb_s_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_csgetrow + + + +subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csgetblk + implicit none + + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_base_csgetblk + + +subroutine psb_s_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csclip + implicit none + + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_base_csclip + +subroutine psb_s_base_mold(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mold + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_mold + +subroutine psb_s_base_transp_2mat(a,b) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_s_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_s_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='s_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_s_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_s_base_transp_2mat + +subroutine psb_s_base_transc_2mat(a,b) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transc_2mat + implicit none + + class(psb_s_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transp(b) +end subroutine psb_s_base_transc_2mat + +subroutine psb_s_base_transp_1mat(a) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_s_base_sparse_mat), intent(inout) :: a + + type(psb_s_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='s_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_s_base_transp_1mat + +subroutine psb_s_base_transc_1mat(a) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transc_1mat + implicit none + + class(psb_s_base_sparse_mat), intent(inout) :: a + + call a%transp() +end subroutine psb_s_base_transc_1mat + + +! == ================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == ================================== + +subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csmm + use psb_error_mod + + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='s_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_csmm + + +subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csmv + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='s_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + +end subroutine psb_s_base_csmv + + +subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_inner_cssm + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='s_base_inner_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_inner_cssm + + +subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_inner_cssv + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='s_base_inner_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_inner_cssv + + +subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cssm + use psb_error_mod + use psb_string_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + + real(psb_spk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='s_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == psb_success_)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else if (psb_toupper(scale_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& + & call a%inner_cssm(sone,x,szero,tmp,info,trans) + + if (info == psb_success_)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == psb_success_)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_s_base_cssm + + +subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cssv + use psb_error_mod + use psb_string_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + + real(psb_spk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='s_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + if (info == psb_success_)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else if (psb_toupper(scale_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + if (beta == szero) then + call a%inner_cssm(alpha,x,szero,y,info,trans) + if (info == psb_success_) call inner_vscal1(nar,d,y) + else + allocate(tmp(nar),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& + & call a%inner_cssm(alpha,x,szero,tmp,info,trans) + + if (info == psb_success_) call inner_vscal1(nar,d,tmp) + if (info == psb_success_)& + & call psb_geaxpby(nar,sone,tmp,beta,y,info) + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +contains + subroutine inner_vscal(n,d,x,y) + implicit none + integer, intent(in) :: n + real(psb_spk_), intent(in) :: d(*),x(*) + real(psb_spk_), intent(out) :: y(*) + integer :: i + + do i=1,n + y(i) = d(i)*x(i) + end do + end subroutine inner_vscal + + + subroutine inner_vscal1(n,d,x) + implicit none + integer, intent(in) :: n + real(psb_spk_), intent(in) :: d(*) + real(psb_spk_), intent(inout) :: x(*) + integer :: i + + do i=1,n + x(i) = d(i)*x(i) + end do + end subroutine inner_vscal1 + +end subroutine psb_s_base_cssv + + +subroutine psb_s_base_scals(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_scals + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_scals + + + +subroutine psb_s_base_scal(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_scal + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_base_scal + + + +function psb_s_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csnmi + + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -sone + + return + +end function psb_s_base_csnmi + +subroutine psb_s_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_get_diag + + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_s_base_get_diag + + + + diff --git a/base/serial/impl/psb_s_coo_impl.f90 b/base/serial/impl/psb_s_coo_impl.f90 new file mode 100644 index 00000000..5908fa75 --- /dev/null +++ b/base/serial/impl/psb_s_coo_impl.f90 @@ -0,0 +1,3033 @@ + +subroutine psb_s_coo_get_diag(a,d,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = szero + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = sone + else + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_get_diag + + +subroutine psb_s_coo_scal(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_scal + use psb_error_mod + use psb_const_mod + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_scal + + +subroutine psb_s_coo_scals(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_scals + + +subroutine psb_s_coo_reallocate_nz(nz,a) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_s_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='s_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_reallocate_nz + +subroutine psb_s_coo_mold(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_mold + use psb_error_mod + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_s_coo_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_coo_mold + + +subroutine psb_s_coo_reinit(a,clear) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_reinit + use psb_error_mod + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = szero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_reinit + + + +subroutine psb_s_coo_trim(a) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_trim + + +subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_s_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_allocate_mnnz + + + +subroutine psb_s_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_print + use psb_string_mod + implicit none + + integer, intent(in) :: iout + class(psb_s_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='s_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_s_coo_print + + + + +function psb_s_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_get_nz_row + implicit none + + class(psb_s_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_s_coo_get_nz_row + +subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cssm + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_base_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + nc = min(size(x,2) , size(y,2)) + nnz = a%get_nzeros() + + if (alpha == szero) then + if (beta == szero) then + do i = 1, m + y(i,1:nc) = szero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + return + end if + + if (beta == szero) then + call inner_coosm(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & m,nc,nnz,a%ia,a%ja,a%val,& + & x,size(x,1),y,size(y,1),info) + do i = 1, m + y(i,1:nc) = alpha*y(i,1:nc) + end do + else + allocate(tmp(m,nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_coosm(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & m,nc,nnz,a%ia,a%ja,a%val,& + & x,size(x,1),tmp,size(tmp,1),info) + do i = 1, m + y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) + end do + end if + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='inner_coosm') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine inner_coosm(tra,lower,unit,sorted,nr,nc,nz,& + & ia,ja,val,x,ldx,y,ldy,info) + implicit none + logical, intent(in) :: tra,lower,unit,sorted + integer, intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) + real(psb_spk_), intent(in) :: val(*), x(ldx,*) + real(psb_spk_), intent(out) :: y(ldy,*) + integer, intent(out) :: info + + integer :: i,j,k,m, ir, jc + real(psb_spk_), allocatable :: acc(:) + + info = psb_success_ + allocate(acc(nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + + + if (.not.sorted) then + info = psb_err_invalid_mat_state_ + return + end if + + nnz = nz + + if (.not.tra) then + + if (lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = szero + do + if (j > nnz) exit + if (ia(j) > i) exit + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j + 1 + end do + y(i,1:nc) = x(i,1:nc) - acc(1:nc) + end do + else if (.not.unit) then + j = 1 + do i=1, nr + acc(1:nc) = szero + do + if (j > nnz) exit + if (ia(j) > i) exit + if (ja(j) == i) then + y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) + j = j + 1 + exit + end if + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j + 1 + end do + end do + end if + + else if (.not.lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = szero + do + if (j < 1) exit + if (ia(j) < i) exit + acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) + j = j - 1 + end do + y(i,1:nc) = x(i,1:nc) - acc(1:nc) + end do + + else if (.not.unit) then + + j = nnz + do i=nr, 1, -1 + acc(1:nc) = szero + do + if (j < 1) exit + if (ia(j) < i) exit + if (ja(j) == i) then + y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) + j = j - 1 + exit + end if + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j - 1 + end do + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /val(j) + j = j - 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /val(j) + j = j + 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j + 1 + end do + end do + end if + end if + end if + end if + end subroutine inner_coosm + +end subroutine psb_s_coo_cssm + + + +subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cssv + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_coo_cssv_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (alpha == szero) then + if (beta == szero) then + do i = 1, m + y(i) = szero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + return + end if + + if (beta == szero) then + call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& + & x,y,info) + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + do i = 1, m + y(i) = alpha*y(i) + end do + else + allocate(tmp(m), stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& + & x,tmp,info) + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + do i = 1, m + y(i) = alpha*tmp(i) + beta*y(i) + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + subroutine inner_coosv(tra,lower,unit,sorted,nr,nz,& + & ia,ja,val,x,y,info) + implicit none + logical, intent(in) :: tra,lower,unit,sorted + integer, intent(in) :: nr,nz,ia(*),ja(*) + real(psb_spk_), intent(in) :: val(*), x(*) + real(psb_spk_), intent(out) :: y(*) + integer, intent(out) :: info + + integer :: i,j,k,m, ir, jc, nnz + real(psb_spk_) :: acc + + info = psb_success_ + if (.not.sorted) then + info = psb_err_invalid_mat_state_ + return + end if + + nnz = nz + + if (.not.tra) then + + if (lower) then + if (unit) then + j = 1 + do i=1, nr + acc = szero + do + if (j > nnz) exit + if (ia(j) > i) exit + acc = acc + val(j)*y(ja(j)) + j = j + 1 + end do + y(i) = x(i) - acc + end do + else if (.not.unit) then + j = 1 + do i=1, nr + acc = szero + do + if (j > nnz) exit + if (ia(j) > i) exit + if (ja(j) == i) then + y(i) = (x(i) - acc)/val(j) + j = j + 1 + exit + end if + acc = acc + val(j)*y(ja(j)) + j = j + 1 + end do + end do + end if + + else if (.not.lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = szero + do + if (j < 1) exit + if (ia(j) < i) exit + acc = acc + val(j)*y(ja(j)) + j = j - 1 + end do + y(i) = x(i) - acc + end do + + else if (.not.unit) then + + j = nnz + do i=nr, 1, -1 + acc = szero + do + if (j < 1) exit + if (ia(j) < i) exit + if (ja(j) == i) then + y(i) = (x(i) - acc)/val(j) + j = j - 1 + exit + end if + acc = acc + val(j)*y(ja(j)) + j = j - 1 + end do + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i) = x(i) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i) = y(i) /val(j) + j = j - 1 + end if + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i) = y(i) /val(j) + j = j + 1 + end if + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j + 1 + end do + end do + end if + end if + end if + end if + + end subroutine inner_coosv + + +end subroutine psb_s_coo_cssv + +subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csmv + implicit none + + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_spk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='s_coo_csmv_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nnz = a%get_nzeros() + + if (alpha == szero) then + if (beta == szero) then + do i = 1, m + y(i) = szero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + return + else + if (a%is_triangle().and.a%is_unit()) then + if (beta == szero) then + do i = 1, min(m,n) + y(i) = alpha*x(i) + enddo + do i = min(m,n)+1, m + y(i) = szero + enddo + else + do i = 1, min(m,n) + y(i) = beta*y(i) + alpha*x(i) + end do + do i = min(m,n)+1, m + y(i) = beta*y(i) + enddo + endif + else + if (beta == szero) then + do i = 1, m + y(i) = szero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + + endif + + end if + + if (.not.tra) then + i = 1 + j = i + if (nnz > 0) then + ir = a%ia(1) + acc = szero + do + if (i>nnz) then + y(ir) = y(ir) + alpha * acc + exit + endif + if (a%ia(i) /= ir) then + y(ir) = y(ir) + alpha * acc + ir = a%ia(i) + acc = szero + endif + acc = acc + a%val(i) * x(a%ja(i)) + i = i + 1 + enddo + end if + + else if (tra) then + + if (alpha == sone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + a%val(i)*x(jc) + enddo + + else if (alpha == -sone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) - a%val(i)*x(jc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + alpha*a%val(i)*x(jc) + enddo + + end if !.....end testing on alpha + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_csmv + + +subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csmm + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_coo_csmm_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + nnz = a%get_nzeros() + + nc = min(size(x,2), size(y,2)) + allocate(acc(nc),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + + if (alpha == szero) then + if (beta == szero) then + do i = 1, m + y(i,1:nc) = szero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + return + else + if (a%is_triangle().and.a%is_unit()) then + if (beta == szero) then + do i = 1, min(m,n) + y(i,1:nc) = alpha*x(i,1:nc) + enddo + do i = min(m,n)+1, m + y(i,1:nc) = szero + enddo + else + do i = 1, min(m,n) + y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) + end do + do i = min(m,n)+1, m + y(i,1:nc) = beta*y(i,1:nc) + enddo + endif + else + if (beta == szero) then + do i = 1, m + y(i,1:nc) = szero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + + endif + + end if + + if (.not.tra) then + i = 1 + j = i + if (nnz > 0) then + ir = a%ia(1) + acc = szero + do + if (i>nnz) then + y(ir,1:nc) = y(ir,1:nc) + alpha * acc + exit + endif + if (a%ia(i) /= ir) then + y(ir,1:nc) = y(ir,1:nc) + alpha * acc + ir = a%ia(i) + acc = szero + endif + acc = acc + a%val(i) * x(a%ja(i),1:nc) + i = i + 1 + enddo + end if + + else if (tra) then + if (alpha == sone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + a%val(i)*x(jc,1:nc) + enddo + + else if (alpha == -sone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + alpha*a%val(i)*x(jc,1:nc) + enddo + + end if !.....end testing on alpha + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_coo_csmm + +function psb_s_coo_csnmi(a) result(res) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csnmi + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='s_base_csnmi' + logical, parameter :: debug=.false. + + + res = szero + nnz = a%get_nzeros() + i = 1 + j = i + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + acc = szero + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + +end function psb_s_coo_csnmi + + + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csgetptn + implicit none + + class(psb_s_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_ibsrch(irw,nza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_ibsrch(lrw,nza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_s_coo_csgetptn + + +subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csgetrow + implicit none + + class(psb_s_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_ibsrch(irw,nza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_ibsrch(lrw,nza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + val(nzin_) = a%val(i) + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + val(nzin_) = a%val(i) + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getrow + +end subroutine psb_s_coo_csgetrow + + +subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csput + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='s_coo_csput_impl' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + info = psb_success_ + call psb_erractionsave(err_act) + + if (nz < 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + isza = a%get_size() + endif + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + call s_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) then + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza,ia1(:),ia2(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_), intent(inout) :: aspk(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -91 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -92 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine s_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nc,nnz,dupl,ng, nr + integer :: debug_level, debug_unit + character(len=20) :: name='s_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + endif + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = i + return + end if + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine s_coo_srch_upd + +end subroutine psb_s_coo_csput + + +subroutine psb_s_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_coo + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act, nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) + + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_cp_coo_to_coo + +subroutine psb_s_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_coo + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_cp_coo_from_coo + + +subroutine psb_s_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_fmt + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_cp_coo_to_fmt + +subroutine psb_s_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_fmt + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_cp_coo_from_fmt + + +subroutine psb_s_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_to_coo + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_mv_coo_to_coo + +subroutine psb_s_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_from_coo + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_mv_coo_from_coo + + +subroutine psb_s_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_to_fmt + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_mv_coo_to_fmt + +subroutine psb_s_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_from_fmt + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_mv_coo_from_fmt + +subroutine psb_s_coo_cp_from(a,b) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cp_from + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + type(psb_s_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_coo_cp_from + +subroutine psb_s_coo_mv_from(a,b) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_mv_from + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_coo_mv_from + + + +subroutine psb_s_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_fix_coo + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + integer, allocatable :: iaux(:) + !locals + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + nza = a%get_nzeros() + if (nza < 2) return + + dupl_ = a%get_dupl() + + call psb_s_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + call a%set_sorted() + call a%set_nzeros(i) + call a%set_asb() + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_fix_coo + + + +subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + implicit none + + integer, intent(in) :: nzin, dupl + integer, intent(inout) :: ia(:), ja(:) + real(psb_spk_), intent(inout) :: val(:) + integer, intent(out) :: nzout, info + integer, intent(in), optional :: idir + !locals + integer, allocatable :: iaux(:) + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + + if (nzin < 2) return + + dupl_ = dupl + + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) return + + + select case(idir_) + + case(0) ! Row major order + + call msort_up(nzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + case(1) ! Col major order + + call msort_up(nzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine psb_s_fix_coo_inner + diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 new file mode 100644 index 00000000..964a17d5 --- /dev/null +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -0,0 +1,2675 @@ + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + +subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csmv + implicit none + class(psb_s_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_spk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='s_csc_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + + if (size(x,1) psb_s_csc_csmm + implicit none + class(psb_s_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_csc_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_s_csc_cssv + implicit none + class(psb_s_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_csc_cssv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (size(x,1) psb_s_csc_cssm + implicit none + class(psb_s_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_base_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + + if (size(x,1) psb_s_csc_csnmi + implicit none + class(psb_s_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer :: i,j,k,m,n, nr, ir, jc, nc, info + real(psb_spk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + nr = a%get_nrows() + nc = a%get_ncols() + allocate(acc(nr),stat=info) + if (info /= psb_success_) then + return + end if + acc(:) = dzero + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + acc(a%ia(j)) = acc(a%ia(j)) + abs(a%val(j)) + end do + end do + do i=1, nr + res = max(res,acc(i)) + end do + deallocate(acc) + +end function psb_s_csc_csnmi + + +subroutine psb_s_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_get_diag + implicit none + class(psb_s_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = sone + else + do i=1, mnm + d(i) = szero + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = szero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_get_diag + + +subroutine psb_s_csc_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_scal + implicit none + class(psb_s_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, n + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, n + do j = a%icp(i), a%icp(i+1) -1 + a%val(j) = a%val(j) * d(a%ia(j)) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_scal + + +subroutine psb_s_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_scals + implicit none + class(psb_s_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_scals + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + +subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csgetptn + implicit none + + class(psb_s_csc_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + + end subroutine csc_getptn + +end subroutine psb_s_csc_csgetptn + + + + +subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csgetrow + implicit none + + class(psb_s_csc_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + call psb_ensure_size(int(1.25*nzin_)+1,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + call psb_ensure_size(int(1.25*nzin_)+1,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + end subroutine csc_getrow + +end subroutine psb_s_csc_csgetrow + + + +subroutine psb_s_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csput + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='s_csc_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_s_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= psb_success_) then + + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_s_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng, nar, nac + integer :: debug_level, debug_unit + character(len=20) :: name='s_csc_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nar = a%get_nrows() + nac = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + + else + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding col that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding col that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_s_csc_srch_upd + +end subroutine psb_s_csc_csput + + + +subroutine psb_s_cp_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_from_coo + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + type(psb_s_coo_sparse_mat) :: tmp + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_s_cp_csc_from_coo + + + +subroutine psb_s_cp_csc_to_coo(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_to_coo + implicit none + + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) + + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ia(j) = a%ia(j) + b%ja(j) = i + b%val(j) = a%val(j) + end do + end do + + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_s_cp_csc_to_coo + + +subroutine psb_s_mv_csc_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_to_coo + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ia,b%ia) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ja,info) + if (info /= psb_success_) return + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ja(j) = i + end do + end do + call a%free() + call b%fix(info) + +end subroutine psb_s_mv_csc_to_coo + + + +subroutine psb_s_mv_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_from_coo + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc, icl + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info, idir=1) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ja,itemp) + call move_alloc(b%ia,a%ia) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%icp,info) + call b%free() + + if (nza <= 0) then + a%icp(:) = 1 + else + a%icp(1) = 1 + if (nc < itemp(nza)) then + write(debug_unit,*) trim(name),': CLSHR=.false. : ',& + &nc,itemp(nza),' Expect trouble!' + info = 12 + end if + + j = 1 + i = 1 + icl = itemp(j) + + outer: do + inner: do + if (i >= icl) exit inner + if (i > nc) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nc,j,nza,icl,idl + exit outer + end if + a%icp(i+1) = a%icp(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= icl) then + a%icp(i+1) = j + icl = itemp(j) + i = i + 1 + endif + if (i > nc) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i > nc) exit + a%icp(i+1) = j + i = i + 1 + end do + + endif + + +end subroutine psb_s_mv_csc_from_coo + + +subroutine psb_s_mv_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_to_fmt + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_s_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_s_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_s_csc_sparse_mat) + call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call move_alloc(a%icp, b%icp) + call move_alloc(a%ia, b%ia) + call move_alloc(a%val, b%val) + call a%free() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_s_mv_csc_to_fmt +!!$ + +subroutine psb_s_cp_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_to_fmt + implicit none + + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_s_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_s_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_s_csc_sparse_mat) + call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) + b%icp = a%icp + b%ia = a%ia + b%val = a%val + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_s_cp_csc_to_fmt + + +subroutine psb_s_mv_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_from_fmt + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_s_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_s_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_s_csc_sparse_mat) + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_s_mv_csc_from_fmt + + + +subroutine psb_s_cp_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_from_fmt + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + !locals + type(psb_s_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_s_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_s_csc_sparse_mat) + call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_s_cp_csc_from_fmt + +subroutine psb_s_csc_mold(a,b,info) + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mold + use psb_error_mod + implicit none + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_s_csc_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csc_mold + +subroutine psb_s_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_s_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='s_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_reallocate_nz + + + +subroutine psb_s_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csgetblk + implicit none + + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_csgetblk + +subroutine psb_s_csc_reinit(a,clear) + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_reinit + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_reinit + +subroutine psb_s_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_trim + implicit none + class(psb_s_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, n + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + n = a%get_ncols() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_trim + +subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_s_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csc_allocate_mnnz + +subroutine psb_s_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_print + implicit none + + integer, intent(in) :: iout + class(psb_s_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='s_csc_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_s_csc_print + +subroutine psb_s_csc_cp_from(a,b) + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_cp_from + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + type(psb_s_csc_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = psb_success_ + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csc_cp_from + +subroutine psb_s_csc_mv_from(a,b) + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mv_from + implicit none + + class(psb_s_csc_sparse_mat), intent(inout) :: a + type(psb_s_csc_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csc_mv_from + + + diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 new file mode 100644 index 00000000..f2e743ea --- /dev/null +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -0,0 +1,2656 @@ + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + +subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csmv + implicit none + class(psb_s_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_spk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='s_csr_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_s_csr_csmm + implicit none + class(psb_s_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_csr_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_s_csr_cssv + implicit none + class(psb_s_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_csr_cssv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (size(x) psb_s_csr_cssm + implicit none + class(psb_s_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='s_csr_cssm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') + + m = a%get_nrows() + nc = min(size(x,2) , size(y,2)) + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (alpha == dzero) then + if (beta == dzero) then + do i = 1, m + y(i,:) = dzero + enddo + else + do i = 1, m + y(i,:) = beta*y(i,:) + end do + endif + return + end if + + if (beta == dzero) then + call inner_csrsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info) + do i = 1, m + y(i,1:nc) = alpha*y(i,1:nc) + end do + else + allocate(tmp(m,nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_csrsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info) + do i = 1, m + y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) + end do + end if + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='inner_csrsm') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine inner_csrsm(tra,lower,unit,nr,nc,& + & irp,ja,val,x,ldx,y,ldy,info) + implicit none + logical, intent(in) :: tra,lower,unit + integer, intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*) + real(psb_spk_), intent(in) :: val(*), x(ldx,*) + real(psb_spk_), intent(out) :: y(ldy,*) + integer, intent(out) :: info + integer :: i,j,k,m, ir, jc + real(psb_spk_), allocatable :: acc(:) + + info = psb_success_ + allocate(acc(nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + + + if (.not.tra) then + + if (lower) then + if (unit) then + do i=1, nr + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=1, nr + acc = dzero + do j=irp(i), irp(i+1)-2 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) + end do + end if + else if (.not.lower) then + + if (unit) then + do i=nr, 1, -1 + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=nr, 1, -1 + acc = dzero + do j=irp(i)+1, irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i)) + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + do i=nr, 1, -1 + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=nr, 1, -1 + y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, nr + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=1, nr + y(i,1:nc) = y(i,1:nc)/val(irp(i)) + acc = y(i,1:nc) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + + end if + end if + end subroutine inner_csrsm + +end subroutine psb_s_csr_cssm + +function psb_s_csr_csnmi(a) result(res) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csnmi + implicit none + class(psb_s_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer :: i,j,k,m,n, nr, ir, jc, nc + real(psb_spk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='s_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_s_csr_csnmi + +subroutine psb_s_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_get_diag + implicit none + class(psb_s_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = sone + else + do i=1, mnm + d(i) = szero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_get_diag + + +subroutine psb_s_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_scal + implicit none + class(psb_s_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_scal + + +subroutine psb_s_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_scals + implicit none + class(psb_s_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_s_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_s_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='s_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_reallocate_nz + +subroutine psb_s_csr_mold(a,b,info) + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_mold + use psb_error_mod + implicit none + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_s_csr_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csr_mold + +subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_s_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_allocate_mnnz + + +subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csgetptn + implicit none + + class(psb_s_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_s_csr_csgetrow + implicit none + + class(psb_s_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_s_csr_csgetblk + implicit none + + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_csgetblk + + + +subroutine psb_s_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csput + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='s_csr_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + + call psb_erractionsave(err_act) + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_s_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= psb_success_) then + + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_s_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng + integer :: debug_level, debug_unit + character(len=20) :: name='s_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + + else + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_s_csr_srch_upd + +end subroutine psb_s_csr_csput + + +subroutine psb_s_csr_reinit(a,clear) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_reinit + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_reinit + +subroutine psb_s_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_trim + implicit none + class(psb_s_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csr_trim + +subroutine psb_s_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_print + implicit none + + integer, intent(in) :: iout + class(psb_s_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='s_csr_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_s_csr_print + + +subroutine psb_s_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_from_coo + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + type(psb_s_coo_sparse_mat) :: tmp + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_s_cp_csr_from_coo + + + +subroutine psb_s_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_to_coo + implicit none + + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_s_cp_csr_to_coo + + +subroutine psb_s_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_to_coo + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%fix(info) + + +end subroutine psb_s_mv_csr_to_coo + + + +subroutine psb_s_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_from_coo + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + if (nza <= 0) then + a%irp(:) = 1 + else + a%irp(1) = 1 + if (nr < itemp(nza)) then + write(debug_unit,*) trim(name),': RWSHR=.false. : ',& + &nr,itemp(nza),' Expect trouble!' + info = 12 + end if + + j = 1 + i = 1 + irw = itemp(j) + + outer: do + inner: do + if (i >= irw) exit inner + if (i>nr) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl + exit outer + end if + a%irp(i+1) = a%irp(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= irw) then + a%irp(i+1) = j + irw = itemp(j) + i = i + 1 + endif + if (i>nr) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i>nr) exit + a%irp(i+1) = j + i = i + 1 + end do + + endif + + +end subroutine psb_s_mv_csr_from_coo + + +subroutine psb_s_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_to_fmt + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_s_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_s_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_s_csr_sparse_mat) + call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_s_mv_csr_to_fmt + + +subroutine psb_s_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_to_fmt + implicit none + + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_s_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_s_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_s_csr_sparse_mat) + call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) + b%irp = a%irp + b%ja = a%ja + b%val = a%val + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_s_cp_csr_to_fmt + + +subroutine psb_s_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_from_fmt + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_s_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_s_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_s_csr_sparse_mat) + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_s_mv_csr_from_fmt + + + +subroutine psb_s_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_from_fmt + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + !locals + type(psb_s_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nz, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_s_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_s_csr_sparse_mat) + call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + call psb_safe_cpy( b%irp, a%irp , info) + call psb_safe_cpy( b%ja , a%ja , info) + call psb_safe_cpy( b%val, a%val , info) + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_s_cp_csr_from_fmt + + +subroutine psb_s_csr_cp_from(a,b) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_cp_from + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + type(psb_s_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = psb_success_ + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csr_cp_from + +subroutine psb_s_csr_mv_from(a,b) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_mv_from + implicit none + + class(psb_s_csr_sparse_mat), intent(inout) :: a + type(psb_s_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csr_mv_from + + diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 new file mode 100644 index 00000000..1cc31802 --- /dev/null +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -0,0 +1,2003 @@ +! == =================================== +! +! +! +! Setters +! +! +! +! +! +! +! == =================================== + + +subroutine psb_s_set_nrows(m,a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_nrows + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_nrows + + +subroutine psb_s_set_ncols(n,a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_ncols + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_ncols + + + +subroutine psb_s_set_state(n,a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_state + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_state + + + +subroutine psb_s_set_dupl(n,a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_dupl + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_dupl + + +subroutine psb_s_set_null(a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_null + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_null + + +subroutine psb_s_set_bld(a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_bld + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_bld + + +subroutine psb_s_set_upd(a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_upd + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_s_set_upd + + +subroutine psb_s_set_asb(a) + use psb_s_mat_mod, psb_protect_name => psb_s_set_asb + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_asb + + +subroutine psb_s_set_sorted(a,val) + use psb_s_mat_mod, psb_protect_name => psb_s_set_sorted + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_sorted + + +subroutine psb_s_set_triangle(a,val) + use psb_s_mat_mod, psb_protect_name => psb_s_set_triangle + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_triangle + + +subroutine psb_s_set_unit(a,val) + use psb_s_mat_mod, psb_protect_name => psb_s_set_unit + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_unit + + +subroutine psb_s_set_lower(a,val) + use psb_s_mat_mod, psb_protect_name => psb_s_set_lower + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_lower + + +subroutine psb_s_set_upper(a,val) + use psb_s_mat_mod, psb_protect_name => psb_s_set_upper + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_s_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_s_mat_mod, psb_protect_name => psb_s_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_sspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 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,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_sparse_print + + + + +subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) + use psb_s_mat_mod, psb_protect_name => psb_s_get_neigh + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_get_neigh + + + +subroutine psb_s_csall(nr,nc,a,info,nz) + use psb_s_mat_mod, psb_protect_name => psb_s_csall + use psb_s_base_mat_mod + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = psb_success_ + allocate(psb_s_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 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csall + + +subroutine psb_s_reallocate_nz(nz,a) + use psb_s_mat_mod, psb_protect_name => psb_s_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_sspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_reallocate_nz + + +subroutine psb_s_free(a) + use psb_s_mat_mod, psb_protect_name => psb_s_free + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_s_free + + +subroutine psb_s_trim(a) + use psb_s_mat_mod, psb_protect_name => psb_s_trim + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_trim + + + +subroutine psb_s_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_s_mat_mod, psb_protect_name => psb_s_csput + use psb_s_base_mat_mod + use psb_error_mod + implicit none + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.a%is_bld()) 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_csput + + +subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csgetptn + implicit none + + class(psb_sspmat_type), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_csgetptn + + +subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csgetrow + implicit none + + class(psb_sspmat_type), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_csgetrow + + + + +subroutine psb_s_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csgetblk + implicit none + + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat), allocatable :: acoo + + + info = 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%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_csgetblk + + + + +subroutine psb_s_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csclip + implicit none + + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat), allocatable :: acoo + + info = 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%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_csclip + + +subroutine psb_s_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_b_csclip + implicit none + + class(psb_sspmat_type), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_b_csclip + + + + +subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cscnv + implicit none + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_s_base_sparse_mat), intent(in), optional :: mold + + + class(psb_s_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 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 b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + +#if defined(HAVE_MOLD) + allocate(altmp, mold=mold,stat=info) +#else + call mold%mold(altmp,info) +#endif + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_s_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_s_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_s_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_s_csr_sparse_mat :: altmp, 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 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%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_cscnv + + + +subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cscnv_ip + implicit none + + class(psb_sspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_s_base_sparse_mat), intent(in), optional :: mold + + + class(psb_s_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 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 + +#if defined(HAVE_MOLD) + allocate(altmp, mold=mold,stat=info) +#else + call mold%mold(altmp,info) +#endif + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_s_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_s_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_s_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_s_csr_sparse_mat :: altmp, 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_cscnv_ip + + + +subroutine psb_s_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cscnv_base + implicit none + class(psb_sspmat_type), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + + + type(psb_s_coo_sparse_mat) :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_cscnv_base + + + +subroutine psb_s_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_clip_d + implicit none + + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(out) :: b + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_clip_d + + + +subroutine psb_s_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_s_clip_d_ip + implicit none + + class(psb_sspmat_type), intent(inout) :: a + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_clip_d_ip + + +subroutine psb_s_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_mv_from + implicit none + class(psb_sspmat_type), intent(out) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer :: info + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b, stat=info) +#else + call b%mold(a%a,info) +#endif + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_s_mv_from + + +subroutine psb_s_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cp_from + implicit none + class(psb_sspmat_type), intent(out) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ +#else + call b%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine psb_s_cp_from + + +subroutine psb_s_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_mv_to + implicit none + class(psb_sspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + integer :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_s_mv_to + + +subroutine psb_s_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cp_to + implicit none + class(psb_sspmat_type), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + integer :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_s_cp_to + + + +subroutine psb_sspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_sspmat_type_move + implicit none + class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call move_alloc(a%a,b%a) + + return +end subroutine psb_sspmat_type_move + + +subroutine psb_sspmat_type_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_sspmat_type_clone + implicit none + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + +#if defined(HAVE_MOLD) + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ +#else + call a%a%mold(b%a,info) +#endif + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%a%cp_from_fmt(a%a, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_sspmat_type_clone + + + +subroutine psb_s_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_transp_1mat + implicit none + class(psb_sspmat_type), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_transp_1mat + + + +subroutine psb_s_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_transp_2mat + implicit none + class(psb_sspmat_type), intent(out) :: a + class(psb_sspmat_type), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b%a,stat=info) +#else + call b%a%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_transp_2mat + + +subroutine psb_s_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_transc_1mat + implicit none + class(psb_sspmat_type), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_transc_1mat + + + +subroutine psb_s_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_s_transc_2mat + implicit none + class(psb_sspmat_type), intent(out) :: a + class(psb_sspmat_type), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b%a,stat=info) +#else + call b%a%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_transc_2mat + + + + +subroutine psb_s_reinit(a,clear) + use psb_s_mat_mod, psb_protect_name => psb_s_reinit + use psb_error_mod + implicit none + + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_s_reinit + + + + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + + +subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csmm + implicit none + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 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%csmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csmm + + +subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_s_mat_mod, psb_protect_name => psb_s_csmv + implicit none + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 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%csmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_csmv + + +subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cssm + implicit none + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 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%cssm(alpha,x,beta,y,info,trans,scale,d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_cssm + + +subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cssv + implicit none + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 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%cssm(alpha,x,beta,y,info,trans,scale,d) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_cssv + + + +function psb_s_csnmi(a) result(res) + use psb_s_mat_mod, psb_protect_name => psb_s_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_s_csnmi + + +subroutine psb_s_get_diag(a,d,info) + use psb_s_mat_mod, psb_protect_name => psb_s_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_get_diag + + +subroutine psb_s_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_scal + implicit none + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_scal + + +subroutine psb_s_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_scals + implicit none + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_scals + + + diff --git a/base/serial/impl/psb_z_base_mat_impl.f90 b/base/serial/impl/psb_z_base_mat_impl.f90 new file mode 100644 index 00000000..9fd6b20b --- /dev/null +++ b/base/serial/impl/psb_z_base_mat_impl.f90 @@ -0,0 +1,1103 @@ +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_z_base_cp_to_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_cp_to_coo + +subroutine psb_z_base_cp_from_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_cp_from_coo + + +subroutine psb_z_base_cp_to_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_cp_to_fmt + +subroutine psb_z_base_cp_from_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_cp_from_fmt + + +subroutine psb_z_base_mv_to_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_mv_to_coo + +subroutine psb_z_base_mv_from_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_mv_from_coo + + +subroutine psb_z_base_mv_to_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_mv_to_fmt + +subroutine psb_z_base_mv_from_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_mv_from_fmt + +subroutine psb_z_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_csput + +subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csgetrow + implicit none + + class(psb_z_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_csgetrow + + + +subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csgetblk + implicit none + + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_base_csgetblk + + +subroutine psb_z_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csclip + implicit none + + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_base_csclip + +subroutine psb_z_base_mold(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mold + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_mold + + +subroutine psb_z_base_transp_2mat(a,b) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_z_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='z_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_z_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/1,0,0,0,0/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_z_base_transp_2mat + +subroutine psb_z_base_transc_2mat(a,b) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transc_2mat + implicit none + + class(psb_z_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transc(b) +end subroutine psb_z_base_transc_2mat + +subroutine psb_z_base_transp_1mat(a) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(inout) :: a + + type(psb_z_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='z_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_z_base_transp_1mat + +subroutine psb_z_base_transc_1mat(a) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transc_1mat + implicit none + + class(psb_z_base_sparse_mat), intent(inout) :: a + + call a%transc() +end subroutine psb_z_base_transc_1mat + + +! == ================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == ================================== + +subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csmm + use psb_error_mod + + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_csmm + + +subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csmv + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + +end subroutine psb_z_base_csmv + + +subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_inner_cssm + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_inner_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_inner_cssm + + +subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_inner_cssv + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_inner_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_inner_cssv + + +subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cssm + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + + complex(psb_dpk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='z_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == psb_success_)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else if (psb_toupper(scale_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& + & call a%inner_cssm(zone,x,zzero,tmp,info,trans) + + if (info == psb_success_)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == psb_success_)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_z_base_cssm + + +subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cssv + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + + complex(psb_dpk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: scale_ + character(len=20) :: name='z_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(scale)) then + scale_ = scale + else + scale_ = 'L' + end if + + if (psb_toupper(scale_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + if (info == psb_success_)& + & call a%inner_cssm(alpha,tmp,beta,y,info,trans) + + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + + else if (psb_toupper(scale_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + if (beta == zzero) then + call a%inner_cssm(alpha,x,zzero,y,info,trans) + if (info == psb_success_) call inner_vscal1(nar,d,y) + else + allocate(tmp(nar),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& + & call a%inner_cssm(alpha,x,zzero,tmp,info,trans) + + if (info == psb_success_) call inner_vscal1(nar,d,tmp) + if (info == psb_success_)& + & call psb_geaxpby(nar,zone,tmp,beta,y,info) + if (info == psb_success_) then + deallocate(tmp,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + end if + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=scale_) + goto 9999 + end if + else + ! Scale is ignored in this case + call a%inner_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='inner_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return +contains + subroutine inner_vscal(n,d,x,y) + implicit none + integer, intent(in) :: n + complex(psb_dpk_), intent(in) :: d(*),x(*) + complex(psb_dpk_), intent(out) :: y(*) + integer :: i + + do i=1,n + y(i) = d(i)*x(i) + end do + end subroutine inner_vscal + + + subroutine inner_vscal1(n,d,x) + implicit none + integer, intent(in) :: n + complex(psb_dpk_), intent(in) :: d(*) + complex(psb_dpk_), intent(inout) :: x(*) + integer :: i + + do i=1,n + x(i) = d(i)*x(i) + end do + end subroutine inner_vscal1 + +end subroutine psb_z_base_cssv + + +subroutine psb_z_base_scals(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_scals + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='z_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_scals + + + +subroutine psb_z_base_scal(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_scal + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='z_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_base_scal + + + +function psb_z_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csnmi + + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -done + + return + +end function psb_z_base_csnmi + +subroutine psb_z_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_get_diag + + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_z_base_get_diag + + + + diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 new file mode 100644 index 00000000..b8139250 --- /dev/null +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -0,0 +1,3233 @@ + +subroutine psb_z_coo_get_diag(a,d,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = zzero + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = zone + else + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_get_diag + + +subroutine psb_z_coo_scal(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_scal + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_scal + + +subroutine psb_z_coo_scals(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_scals + + +subroutine psb_z_coo_reallocate_nz(nz,a) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_z_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='z_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_reallocate_nz + +subroutine psb_z_coo_mold(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_mold + use psb_error_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_z_coo_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_coo_mold + + +subroutine psb_z_coo_reinit(a,clear) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_reinit + use psb_error_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_reinit + + + +subroutine psb_z_coo_trim(a) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_trim + + +subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_z_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_allocate_mnnz + + + +subroutine psb_z_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_print + use psb_string_mod + implicit none + + integer, intent(in) :: iout + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='z_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_z_coo_print + + + + +function psb_z_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_get_nz_row + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_z_coo_get_nz_row + +subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cssm + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:,:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_base_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + nc = min(size(x,2) , size(y,2)) + nnz = a%get_nzeros() + + if (alpha == zzero) then + if (beta == zzero) then + do i = 1, m + y(i,1:nc) = zzero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + return + end if + + if (beta == zzero) then + call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & m,nc,nnz,a%ia,a%ja,a%val,& + & x,size(x,1),y,size(y,1),info) + do i = 1, m + y(i,1:nc) = alpha*y(i,1:nc) + end do + else + allocate(tmp(m,nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & m,nc,nnz,a%ia,a%ja,a%val,& + & x,size(x,1),tmp,size(tmp,1),info) + do i = 1, m + y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) + end do + end if + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='inner_coosm') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& + & ia,ja,val,x,ldx,y,ldy,info) + implicit none + logical, intent(in) :: tra,ctra,lower,unit,sorted + integer, intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) + complex(psb_dpk_), intent(in) :: val(*), x(ldx,*) + complex(psb_dpk_), intent(out) :: y(ldy,*) + integer, intent(out) :: info + + integer :: i,j,k,m, ir, jc + complex(psb_dpk_), allocatable :: acc(:) + + info = psb_success_ + allocate(acc(nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + + + if (.not.sorted) then + info = psb_err_invalid_mat_state_ + return + end if + + nnz = nz + + if ((.not.tra).and.(.not.ctra)) then + + if (lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = zzero + do + if (j > nnz) exit + if (ia(j) > i) exit + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j + 1 + end do + y(i,1:nc) = x(i,1:nc) - acc(1:nc) + end do + else if (.not.unit) then + j = 1 + do i=1, nr + acc(1:nc) = zzero + do + if (j > nnz) exit + if (ia(j) > i) exit + if (ja(j) == i) then + y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) + j = j + 1 + exit + end if + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j + 1 + end do + end do + end if + + else if (.not.lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = zzero + do + if (j < 1) exit + if (ia(j) < i) exit + acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) + j = j - 1 + end do + y(i,1:nc) = x(i,1:nc) - acc(1:nc) + end do + + else if (.not.unit) then + + j = nnz + do i=nr, 1, -1 + acc(1:nc) = zzero + do + if (j < 1) exit + if (ia(j) < i) exit + if (ja(j) == i) then + y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) + j = j - 1 + exit + end if + acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) + j = j - 1 + end do + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /val(j) + j = j - 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /val(j) + j = j + 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j + 1 + end do + end do + end if + end if + end if + + else if (ctra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /conjg(val(j)) + j = j - 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i,1:nc) = y(i,1:nc) /conjg(val(j)) + j = j + 1 + end if + acc(1:nc) = y(i,1:nc) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j + 1 + end do + end do + end if + end if + end if + end if + end subroutine inner_coosm + +end subroutine psb_z_coo_cssm + + + +subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cssv + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_coo_cssv_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + m = a%get_nrows() + if (size(x,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/3,m,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (alpha == zzero) then + if (beta == zzero) then + do i = 1, m + y(i) = zzero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + return + end if + + if (beta == zzero) then + call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& + & x,y,info) + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + do i = 1, m + y(i) = alpha*y(i) + end do + else + allocate(tmp(m), stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& + & x,tmp,info) + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + do i = 1, m + y(i) = alpha*tmp(i) + beta*y(i) + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +contains + + subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& + & ia,ja,val,x,y,info) + implicit none + logical, intent(in) :: tra,ctra,lower,unit,sorted + integer, intent(in) :: nr,nz,ia(*),ja(*) + complex(psb_dpk_), intent(in) :: val(*), x(*) + complex(psb_dpk_), intent(out) :: y(*) + integer, intent(out) :: info + + integer :: i,j,k,m, ir, jc, nnz + complex(psb_dpk_) :: acc + + info = psb_success_ + if (.not.sorted) then + info = psb_err_invalid_mat_state_ + return + end if + + nnz = nz + + if ((.not.tra).and.(.not.ctra)) then + + if (lower) then + if (unit) then + j = 1 + do i=1, nr + acc = zzero + do + if (j > nnz) exit + if (ia(j) > i) exit + acc = acc + val(j)*y(ja(j)) + j = j + 1 + end do + y(i) = x(i) - acc + end do + else if (.not.unit) then + j = 1 + do i=1, nr + acc = zzero + do + if (j > nnz) exit + if (ia(j) > i) exit + if (ja(j) == i) then + y(i) = (x(i) - acc)/val(j) + j = j + 1 + exit + end if + acc = acc + val(j)*y(ja(j)) + j = j + 1 + end do + end do + end if + + else if (.not.lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = zzero + do + if (j < 1) exit + if (ia(j) < i) exit + acc = acc + val(j)*y(ja(j)) + j = j - 1 + end do + y(i) = x(i) - acc + end do + + else if (.not.unit) then + + j = nnz + do i=nr, 1, -1 + acc = zzero + do + if (j < 1) exit + if (ia(j) < i) exit + if (ja(j) == i) then + y(i) = (x(i) - acc)/val(j) + j = j - 1 + exit + end if + acc = acc + val(j)*y(ja(j)) + j = j - 1 + end do + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i) = x(i) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i) = y(i) /val(j) + j = j - 1 + end if + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i) = y(i) /val(j) + j = j + 1 + end if + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + j = j + 1 + end do + end do + end if + end if + end if + + else if (ctra) then + + do i=1, nr + y(i) = x(i) + end do + + if (lower) then + if (unit) then + j = nnz + do i=nr, 1, -1 + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + j = j - 1 + end do + end do + else if (.not.unit) then + j = nnz + do i=nr, 1, -1 + if (ja(j) == i) then + y(i) = y(i) /conjg(val(j)) + j = j - 1 + end if + acc = y(i) + do + if (j < 1) exit + if (ia(j) < i) exit + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + j = j - 1 + end do + end do + + else if (.not.lower) then + if (unit) then + j = 1 + do i=1, nr + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + j = j + 1 + end do + end do + else if (.not.unit) then + j = 1 + do i=1, nr + if (ja(j) == i) then + y(i) = y(i) /conjg(val(j)) + j = j + 1 + end if + acc = y(i) + do + if (j > nnz) exit + if (ia(j) > i) exit + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + j = j + 1 + end do + end do + end if + end if + end if + end if + + end subroutine inner_coosv + + +end subroutine psb_z_coo_cssv + +subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csmv + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_dpk_) :: acc + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_coo_csmv_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + nnz = a%get_nzeros() + + if (alpha == zzero) then + if (beta == zzero) then + do i = 1, m + y(i) = zzero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + return + else + if (a%is_triangle().and.a%is_unit()) then + if (beta == zzero) then + do i = 1, min(m,n) + y(i) = alpha*x(i) + enddo + do i = min(m,n)+1, m + y(i) = zzero + enddo + else + do i = 1, min(m,n) + y(i) = beta*y(i) + alpha*x(i) + end do + do i = min(m,n)+1, m + y(i) = beta*y(i) + enddo + endif + else + if (beta == zzero) then + do i = 1, m + y(i) = zzero + enddo + else + do i = 1, m + y(i) = beta*y(i) + end do + endif + + endif + + end if + + if ((.not.tra).and.(.not.ctra)) then + i = 1 + j = i + if (nnz > 0) then + ir = a%ia(1) + acc = zzero + do + if (i>nnz) then + y(ir) = y(ir) + alpha * acc + exit + endif + if (a%ia(i) /= ir) then + y(ir) = y(ir) + alpha * acc + ir = a%ia(i) + acc = zzero + endif + acc = acc + a%val(i) * x(a%ja(i)) + i = i + 1 + enddo + end if + + else if (tra) then + + if (alpha == zone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + a%val(i)*x(jc) + enddo + + else if (alpha == -zone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) - a%val(i)*x(jc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + alpha*a%val(i)*x(jc) + enddo + + end if !.....end testing on alpha + + else if (ctra) then + + if (alpha == zone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + conjg(a%val(i))*x(jc) + enddo + + else if (alpha == -zone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) - conjg(a%val(i))*x(jc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir) = y(ir) + alpha*conjg(a%val(i))*x(jc) + enddo + + end if !.....end testing on alpha + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_csmv + + +subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csmm + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_), allocatable :: acc(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_coo_csmm_impl' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + if (size(x,1) < n) then + info = 36 + call psb_errpush(info,name,i_err=(/3,n,0,0,0/)) + goto 9999 + end if + if (size(y,1) < m) then + info = 36 + call psb_errpush(info,name,i_err=(/5,m,0,0,0/)) + goto 9999 + end if + + nnz = a%get_nzeros() + + nc = min(size(x,2), size(y,2)) + allocate(acc(nc),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + + if (alpha == zzero) then + if (beta == zzero) then + do i = 1, m + y(i,1:nc) = zzero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + return + else + if (a%is_triangle().and.a%is_unit()) then + if (beta == zzero) then + do i = 1, min(m,n) + y(i,1:nc) = alpha*x(i,1:nc) + enddo + do i = min(m,n)+1, m + y(i,1:nc) = zzero + enddo + else + do i = 1, min(m,n) + y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) + end do + do i = min(m,n)+1, m + y(i,1:nc) = beta*y(i,1:nc) + enddo + endif + else + if (beta == zzero) then + do i = 1, m + y(i,1:nc) = zzero + enddo + else + do i = 1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + endif + + endif + + end if + + if ((.not.tra).and.(.not.ctra)) then + i = 1 + j = i + if (nnz > 0) then + ir = a%ia(1) + acc = zzero + do + if (i>nnz) then + y(ir,1:nc) = y(ir,1:nc) + alpha * acc + exit + endif + if (a%ia(i) /= ir) then + y(ir,1:nc) = y(ir,1:nc) + alpha * acc + ir = a%ia(i) + acc = zzero + endif + acc = acc + a%val(i) * x(a%ja(i),1:nc) + i = i + 1 + enddo + end if + + else if (tra) then + if (alpha == zone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + a%val(i)*x(jc,1:nc) + enddo + + else if (alpha == -zone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + alpha*a%val(i)*x(jc,1:nc) + enddo + + end if !.....end testing on alpha + + else if (ctra) then + + if (alpha == zone) then + i = 1 + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + conjg(a%val(i))*x(jc,1:nc) + enddo + + else if (alpha == -zone) then + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) - conjg(a%val(i))*x(jc,1:nc) + enddo + + else + + do i=1,nnz + ir = a%ja(i) + jc = a%ia(i) + y(ir,1:nc) = y(ir,1:nc) + alpha*conjg(a%val(i))*x(jc,1:nc) + enddo + + end if !.....end testing on alpha + + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_coo_csmm + +function psb_z_coo_csnmi(a) result(res) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csnmi + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='z_base_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + nnz = a%get_nzeros() + i = 1 + j = i + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + acc = dzero + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + +end function psb_z_coo_csnmi + + + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csgetptn + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_ibsrch(irw,nza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_ibsrch(lrw,nza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_z_coo_csgetptn + + +subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csgetrow + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_ibsrch(irw,nza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_ibsrch(lrw,nza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + val(nzin_) = a%val(i) + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + val(nzin_) = a%val(i) + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getrow + +end subroutine psb_z_coo_csgetrow + + +subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csput + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='z_coo_csput_impl' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + info = psb_success_ + call psb_erractionsave(err_act) + + if (nz < 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + isza = a%get_size() + endif + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + call z_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) then + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer, intent(in) :: ia(:),ja(:) + integer, intent(inout) :: nza,ia1(:),ia2(:) + complex(psb_dpk_), intent(in) :: val(:) + complex(psb_dpk_), intent(inout) :: aspk(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -91 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + if (nza > maxsz) then + info = -92 + return + endif + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine z_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nc,nnz,dupl,ng, nr + integer :: debug_level, debug_unit + character(len=20) :: name='z_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + endif + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = i + return + end if + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_ibsrch(ir,nnz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_issrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine z_coo_srch_upd + +end subroutine psb_z_coo_csput + + +subroutine psb_z_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_coo + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act, nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_cp_coo_to_coo + +subroutine psb_z_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_coo + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_cp_coo_from_coo + + +subroutine psb_z_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_fmt + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_cp_coo_to_fmt + +subroutine psb_z_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_fmt + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_cp_coo_from_fmt + + +subroutine psb_z_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_to_coo + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_mv_coo_to_coo + +subroutine psb_z_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_from_coo + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_mv_coo_from_coo + + +subroutine psb_z_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_to_fmt + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_mv_coo_to_fmt + +subroutine psb_z_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_from_fmt + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_mv_coo_from_fmt + +subroutine psb_z_coo_cp_from(a,b) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cp_from + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + type(psb_z_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_coo_cp_from + +subroutine psb_z_coo_mv_from(a,b) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_mv_from + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_coo_mv_from + + + +subroutine psb_z_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_fix_coo + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + integer, allocatable :: iaux(:) + !locals + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + nza = a%get_nzeros() + if (nza < 2) return + + dupl_ = a%get_dupl() + + call psb_z_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + call a%set_sorted() + call a%set_nzeros(i) + call a%set_asb() + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_fix_coo + + + +subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + implicit none + + integer, intent(in) :: nzin, dupl + integer, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), intent(inout) :: val(:) + integer, intent(out) :: nzout, info + integer, intent(in), optional :: idir + !locals + integer, allocatable :: iaux(:) + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act + integer :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = 0 + endif + + + if (nzin < 2) return + + dupl_ = dupl + + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) return + + + select case(idir_) + + case(0) ! Row major order + + call msort_up(nzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + case(1) ! Col major order + + call msort_up(nzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine psb_z_fix_coo_inner + diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 new file mode 100644 index 00000000..4c84098c --- /dev/null +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -0,0 +1,3038 @@ + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + +subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csmv + implicit none + class(psb_z_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_dpk_) :: acc + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_csc_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra.or.ctra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + + if (size(x,1) psb_z_csc_csmm + implicit none + class(psb_z_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_), allocatable :: acc(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_csc_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra.or.ctra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_z_csc_cssv + implicit none + class(psb_z_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_csc_cssv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + m = a%get_nrows() + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (size(x,1) psb_z_csc_cssm + implicit none + class(psb_z_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:,:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_base_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + m = a%get_nrows() + nc = min(size(x,2) , size(y,2)) + + if (size(x,1) psb_z_csc_csnmi + implicit none + class(psb_z_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nr, ir, jc, nc, info + real(psb_dpk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='z_csnmi' + logical, parameter :: debug=.false. + + + res = zzero + nr = a%get_nrows() + nc = a%get_ncols() + allocate(acc(nr),stat=info) + if (info /= psb_success_) then + return + end if + acc(:) = dzero + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + acc(a%ia(j)) = acc(a%ia(j)) + abs(a%val(j)) + end do + end do + do i=1, nr + res = max(res,acc(i)) + end do + deallocate(acc) + +end function psb_z_csc_csnmi + + +subroutine psb_z_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_get_diag + implicit none + class(psb_z_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = zone + else + do i=1, mnm + d(i) = zzero + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = zzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_get_diag + + +subroutine psb_z_csc_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_scal + implicit none + class(psb_z_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, n + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, n + do j = a%icp(i), a%icp(i+1) -1 + a%val(j) = a%val(j) * d(a%ia(j)) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_scal + + +subroutine psb_z_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_scals + implicit none + class(psb_z_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_scals + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + +subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csgetptn + implicit none + + class(psb_z_csc_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + + end subroutine csc_getptn + +end subroutine psb_z_csc_csgetptn + + + + +subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csgetrow + implicit none + + class(psb_z_csc_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + call psb_ensure_size(int(1.25*nzin_)+1,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+1,ia,info) + call psb_ensure_size(int(1.25*nzin_)+1,ja,info) + call psb_ensure_size(int(1.25*nzin_)+1,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + end subroutine csc_getrow + +end subroutine psb_z_csc_csgetrow + + + +subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csput + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='z_csc_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_z_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= psb_success_) then + + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_z_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng, nar, nac + integer :: debug_level, debug_unit + character(len=20) :: name='z_csc_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nar = a%get_nrows() + nac = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + + else + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding col that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr=i2-i1 + + ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ir,' in: ',i1,i2,& + & ' : ',a%ia(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding col that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_z_csc_srch_upd + +end subroutine psb_z_csc_csput + + + +subroutine psb_z_cp_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_from_coo + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + type(psb_z_coo_sparse_mat) :: tmp + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_z_cp_csc_from_coo + + + +subroutine psb_z_cp_csc_to_coo(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_to_coo + implicit none + + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ia(j) = a%ia(j) + b%ja(j) = i + b%val(j) = a%val(j) + end do + end do + + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_z_cp_csc_to_coo + + +subroutine psb_z_mv_csc_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_to_coo + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ia,b%ia) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ja,info) + if (info /= psb_success_) return + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ja(j) = i + end do + end do + call a%free() + call b%fix(info) + +end subroutine psb_z_mv_csc_to_coo + + + +subroutine psb_z_mv_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_from_coo + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc, icl + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info, idir=1) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ja,itemp) + call move_alloc(b%ia,a%ia) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%icp,info) + call b%free() + + if (nza <= 0) then + a%icp(:) = 1 + else + a%icp(1) = 1 + if (nc < itemp(nza)) then + write(debug_unit,*) trim(name),': CLSHR=.false. : ',& + &nc,itemp(nza),' Expect trouble!' + info = 12 + end if + + j = 1 + i = 1 + icl = itemp(j) + + outer: do + inner: do + if (i >= icl) exit inner + if (i > nc) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nc,j,nza,icl,idl + exit outer + end if + a%icp(i+1) = a%icp(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= icl) then + a%icp(i+1) = j + icl = itemp(j) + i = i + 1 + endif + if (i > nc) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i > nc) exit + a%icp(i+1) = j + i = i + 1 + end do + + endif + + +end subroutine psb_z_mv_csc_from_coo + + +subroutine psb_z_mv_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_to_fmt + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_z_csc_sparse_mat) + call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call move_alloc(a%icp, b%icp) + call move_alloc(a%ia, b%ia) + call move_alloc(a%val, b%val) + call a%free() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_z_mv_csc_to_fmt +!!$ + +subroutine psb_z_cp_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_to_fmt + implicit none + + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_z_csc_sparse_mat) + call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + b%icp = a%icp + b%ia = a%ia + b%val = a%val + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_z_cp_csc_to_fmt + + +subroutine psb_z_mv_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_from_fmt + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_z_csc_sparse_mat) + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_z_mv_csc_from_fmt + + + +subroutine psb_z_cp_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_from_fmt + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_z_csc_sparse_mat) + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_z_cp_csc_from_fmt + +subroutine psb_z_csc_mold(a,b,info) + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mold + use psb_error_mod + implicit none + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_z_csc_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csc_mold + +subroutine psb_z_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_z_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='z_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_reallocate_nz + + + +subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csgetblk + implicit none + + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_csgetblk + +subroutine psb_z_csc_reinit(a,clear) + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_reinit + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_reinit + +subroutine psb_z_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_trim + implicit none + class(psb_z_csc_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, n + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + n = a%get_ncols() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_trim + +subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_z_csc_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csc_allocate_mnnz + +subroutine psb_z_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_print + implicit none + + integer, intent(in) :: iout + class(psb_z_csc_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='z_csc_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_z_csc_print + +subroutine psb_z_csc_cp_from(a,b) + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_cp_from + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + type(psb_z_csc_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = psb_success_ + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + a%icp = b%icp + a%ia = b%ia + a%val = b%val + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csc_cp_from + +subroutine psb_z_csc_mv_from(a,b) + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mv_from + implicit none + + class(psb_z_csc_sparse_mat), intent(inout) :: a + type(psb_z_csc_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csc_mv_from + + + diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 new file mode 100644 index 00000000..bb8f66f2 --- /dev/null +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -0,0 +1,2847 @@ + + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + +subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csmv + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_dpk_) :: acc + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_csr_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_z_csr_csmm + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_), allocatable :: acc(:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_csr_csmm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + if (tra) then + m = a%get_ncols() + n = a%get_nrows() + else + n = a%get_ncols() + m = a%get_nrows() + end if + + if (size(x,1) psb_z_csr_cssv + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:) + logical :: tra,ctra + Integer :: err_act + character(len=20) :: name='z_csr_cssv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + m = a%get_nrows() + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (size(x) psb_z_csr_cssm + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:,:) + logical :: tra, ctra + Integer :: err_act + character(len=20) :: name='z_csr_cssm' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') + + m = a%get_nrows() + nc = min(size(x,2) , size(y,2)) + + if (.not. (a%is_triangle())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (alpha == dzero) then + if (beta == dzero) then + do i = 1, m + y(i,:) = dzero + enddo + else + do i = 1, m + y(i,:) = beta*y(i,:) + end do + endif + return + end if + + if (beta == dzero) then + call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info) + do i = 1, m + y(i,1:nc) = alpha*y(i,1:nc) + end do + else + allocate(tmp(m,nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& + & a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info) + do i = 1, m + y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) + end do + end if + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='inner_csrsm') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine inner_csrsm(tra,ctra,lower,unit,nr,nc,& + & irp,ja,val,x,ldx,y,ldy,info) + implicit none + logical, intent(in) :: tra,ctra,lower,unit + integer, intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*) + complex(psb_dpk_), intent(in) :: val(*), x(ldx,*) + complex(psb_dpk_), intent(out) :: y(ldy,*) + integer, intent(out) :: info + integer :: i,j,k,m, ir, jc + complex(psb_dpk_), allocatable :: acc(:) + + info = psb_success_ + allocate(acc(nc), stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + + + if ((.not.tra).and.(.not.ctra)) then + if (lower) then + if (unit) then + do i=1, nr + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=1, nr + acc = dzero + do j=irp(i), irp(i+1)-2 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) + end do + end if + else if (.not.lower) then + + if (unit) then + do i=nr, 1, -1 + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = x(i,1:nc) - acc + end do + else if (.not.unit) then + do i=nr, 1, -1 + acc = dzero + do j=irp(i)+1, irp(i+1)-1 + acc = acc + val(j)*y(ja(j),1:nc) + end do + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i)) + end do + end if + + end if + + else if (tra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + do i=nr, 1, -1 + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=nr, 1, -1 + y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, nr + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=1, nr + y(i,1:nc) = y(i,1:nc)/val(irp(i)) + acc = y(i,1:nc) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + end do + end do + end if + + end if + + else if (ctra) then + + do i=1, nr + y(i,1:nc) = x(i,1:nc) + end do + + if (lower) then + if (unit) then + do i=nr, 1, -1 + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=nr, 1, -1 + y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i+1)-1)) + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, nr + acc = y(i,1:nc) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=1, nr + y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i))) + acc = y(i,1:nc) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + end do + end do + end if + + end if + end if + end subroutine inner_csrsm + +end subroutine psb_z_csr_cssm + +function psb_z_csr_csnmi(a) result(res) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csnmi + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer :: i,j,k,m,n, nr, ir, jc, nc + real(psb_dpk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='z_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_z_csr_csnmi + +subroutine psb_z_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_get_diag + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + if (a%is_triangle().and.a%is_unit()) then + d(1:mnm) = zone + else + do i=1, mnm + d(i) = zzero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = zzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_get_diag + + +subroutine psb_z_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_scal + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_scal + + +subroutine psb_z_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_scals + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_scals + + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_z_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_reallocate_nz + implicit none + integer, intent(in) :: nz + class(psb_z_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='z_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_reallocate_nz + +subroutine psb_z_csr_mold(a,b,info) + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_mold + use psb_error_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out), allocatable :: b + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + allocate(psb_z_csr_sparse_mat :: b, stat=info) + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csr_mold + +subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_allocate_mnnz + implicit none + integer, intent(in) :: m,n + class(psb_z_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_allocate_mnnz + + +subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csgetptn + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_z_csr_csgetrow + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer :: nzin_, jmin_, jmax_, err_act, i + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_z_csr_csgetblk + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_csgetblk + + + +subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csput + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='z_csr_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + + call psb_erractionsave(err_act) + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_z_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= psb_success_) then + + info = psb_err_invalid_mat_state_ + end if + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +contains + + subroutine psb_z_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax + integer, intent(in) :: ia(:),ja(:) + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + integer :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng + integer :: debug_level, debug_unit + character(len=20) :: name='z_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + + else + + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Was searching ',ic,' in: ',i1,i2,& + & ' : ',a%ja(i1:i2-1) + info = i + return + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = i + return + end if + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarding row that does not belong to us.' + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_z_csr_srch_upd + +end subroutine psb_z_csr_csput + + +subroutine psb_z_csr_reinit(a,clear) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_reinit + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_reinit + +subroutine psb_z_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_trim + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csr_trim + +subroutine psb_z_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_print + implicit none + + integer, intent(in) :: iout + class(psb_z_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='z_csr_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_z_csr_print + + +subroutine psb_z_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_from_coo + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + type(psb_z_coo_sparse_mat) :: tmp + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_z_cp_csr_from_coo + + + +subroutine psb_z_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_to_coo + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_z_cp_csr_to_coo + + +subroutine psb_z_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_to_coo + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, nc,i,j,irw, idl,err_act + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%fix(info) + + +end subroutine psb_z_mv_csr_to_coo + + + +subroutine psb_z_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_from_coo + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + integer, allocatable :: itemp(:) + !locals + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + if (nza <= 0) then + a%irp(:) = 1 + else + a%irp(1) = 1 + if (nr < itemp(nza)) then + write(debug_unit,*) trim(name),': RWSHR=.false. : ',& + &nr,itemp(nza),' Expect trouble!' + info = 12 + end if + + j = 1 + i = 1 + irw = itemp(j) + + outer: do + inner: do + if (i >= irw) exit inner + if (i>nr) then + write(debug_unit,*) trim(name),& + & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl + exit outer + end if + a%irp(i+1) = a%irp(i) + i = i + 1 + end do inner + j = j + 1 + if (j > nza) exit + if (itemp(j) /= irw) then + a%irp(i+1) = j + irw = itemp(j) + i = i + 1 + endif + if (i>nr) exit + enddo outer + ! + ! Cleanup empty rows at the end + ! + if (j /= (nza+1)) then + write(debug_unit,*) trim(name),': Problem from loop :',j,nza + info = 13 + endif + do + if (i>nr) exit + a%irp(i+1) = j + i = i + 1 + end do + + endif + + +end subroutine psb_z_mv_csr_from_coo + + +subroutine psb_z_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_to_fmt + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_z_csr_sparse_mat) + call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_z_mv_csr_to_fmt + + +subroutine psb_z_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_to_fmt + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_z_csr_sparse_mat) + call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + b%irp = a%irp + b%ja = a%ja + b%val = a%val + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_z_cp_csr_to_fmt + + +subroutine psb_z_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_from_fmt + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nza, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_z_csr_sparse_mat) + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_z_mv_csr_from_fmt + + + +subroutine psb_z_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_from_fmt + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + !locals + type(psb_z_coo_sparse_mat) :: tmp + logical :: rwshr_ + Integer :: nz, nr, i,j,irw, idl,err_act, nc + Integer, Parameter :: maxtry=8 + integer :: debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_z_csr_sparse_mat) + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_z_cp_csr_from_fmt + + +subroutine psb_z_csr_cp_from(a,b) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_cp_from + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + type(psb_z_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = psb_success_ + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csr_cp_from + +subroutine psb_z_csr_mv_from(a,b) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_mv_from + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + type(psb_z_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csr_mv_from + + diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 new file mode 100644 index 00000000..7873074d --- /dev/null +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -0,0 +1,2002 @@ +! == =================================== +! +! +! +! Setters +! +! +! +! +! +! +! == =================================== + + +subroutine psb_z_set_nrows(m,a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_nrows + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_nrows + + +subroutine psb_z_set_ncols(n,a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_ncols + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_ncols + + + +subroutine psb_z_set_state(n,a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_state + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_state + + + +subroutine psb_z_set_dupl(n,a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_dupl + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_dupl + + +subroutine psb_z_set_null(a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_null + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_null + + +subroutine psb_z_set_bld(a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_bld + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_bld + + +subroutine psb_z_set_upd(a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_upd + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + +end subroutine psb_z_set_upd + + +subroutine psb_z_set_asb(a) + use psb_z_mat_mod, psb_protect_name => psb_z_set_asb + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_asb + + +subroutine psb_z_set_sorted(a,val) + use psb_z_mat_mod, psb_protect_name => psb_z_set_sorted + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_sorted + + +subroutine psb_z_set_triangle(a,val) + use psb_z_mat_mod, psb_protect_name => psb_z_set_triangle + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_triangle + + +subroutine psb_z_set_unit(a,val) + use psb_z_mat_mod, psb_protect_name => psb_z_set_unit + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_unit + + +subroutine psb_z_set_lower(a,val) + use psb_z_mat_mod, psb_protect_name => psb_z_set_lower + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_lower + + +subroutine psb_z_set_upper(a,val) + use psb_z_mat_mod, psb_protect_name => psb_z_set_upper + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_z_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_z_mat_mod, psb_protect_name => psb_z_sparse_print + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_zspmat_type), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 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,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_sparse_print + + + + +subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) + use psb_z_mat_mod, psb_protect_name => psb_z_get_neigh + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_get_neigh + + + +subroutine psb_z_csall(nr,nc,a,info,nz) + use psb_z_mat_mod, psb_protect_name => psb_z_csall + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = psb_success_ + allocate(psb_z_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 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csall + + +subroutine psb_z_reallocate_nz(nz,a) + use psb_z_mat_mod, psb_protect_name => psb_z_reallocate_nz + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_zspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_reallocate_nz + + +subroutine psb_z_free(a) + use psb_z_mat_mod, psb_protect_name => psb_z_free + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_z_free + + +subroutine psb_z_trim(a) + use psb_z_mat_mod, psb_protect_name => psb_z_trim + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_trim + + + +subroutine psb_z_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_mat_mod, psb_protect_name => psb_z_csput + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.a%is_bld()) 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_csput + + +subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csgetptn + implicit none + + class(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_csgetptn + + +subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csgetrow + implicit none + + class(psb_zspmat_type), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_csgetrow + + + + +subroutine psb_z_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csgetblk + implicit none + + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + + + info = 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%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_csgetblk + + + + +subroutine psb_z_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csclip + implicit none + + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + + info = 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%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_csclip + + +subroutine psb_z_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_b_csclip + implicit none + + class(psb_zspmat_type), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_b_csclip + + + + +subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cscnv + implicit none + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + + + class(psb_z_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 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 b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + +#if defined(HAVE_MOLD) + allocate(altmp, mold=mold,stat=info) +#else + call mold%mold(altmp,info) +#endif + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_z_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_z_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_z_csr_sparse_mat :: altmp, 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 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%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_cscnv + + + +subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cscnv_ip + implicit none + + class(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + + + class(psb_z_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 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 + +#if defined(HAVE_MOLD) + allocate(altmp, mold=mold,stat=info) +#else + call mold%mold(altmp,info) +#endif + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_z_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_z_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_z_csr_sparse_mat :: altmp, 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_cscnv_ip + + + +subroutine psb_z_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cscnv_base + implicit none + class(psb_zspmat_type), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + + + type(psb_z_coo_sparse_mat) :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_cscnv_base + + + +subroutine psb_z_clip_d(a,b,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_clip_d + implicit none + + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(out) :: b + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_clip_d + + + +subroutine psb_z_clip_d_ip(a,info) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_z_clip_d_ip + implicit none + + class(psb_zspmat_type), intent(inout) :: a + integer,intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clip_diag' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + integer :: i, j, nz + + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_clip_d_ip + + +subroutine psb_z_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_mv_from + implicit none + class(psb_zspmat_type), intent(out) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer :: info + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b, stat=info) +#else + call b%mold(a%a,info) +#endif + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_z_mv_from + + +subroutine psb_z_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cp_from + implicit none + class(psb_zspmat_type), intent(out) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ +#else + call b%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if +end subroutine psb_z_cp_from + + +subroutine psb_z_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_mv_to + implicit none + class(psb_zspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_z_mv_to + + +subroutine psb_z_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cp_to + implicit none + class(psb_zspmat_type), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_z_cp_to + + + +subroutine psb_zspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_zspmat_type_move + implicit none + class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call move_alloc(a%a,b%a) + + return +end subroutine psb_zspmat_type_move + + +subroutine psb_zspmat_type_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_zspmat_type_clone + implicit none + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + +#if defined(HAVE_MOLD) + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ +#else + call a%a%mold(b%a,info) +#endif + if (info == psb_success_) call b%a%cp_from_fmt(a%a, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_zspmat_type_clone + + + +subroutine psb_z_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_transp_1mat + implicit none + class(psb_zspmat_type), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_transp_1mat + + + +subroutine psb_z_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_transp_2mat + implicit none + class(psb_zspmat_type), intent(out) :: a + class(psb_zspmat_type), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b%a,stat=info) +#else + call b%a%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_transp_2mat + + +subroutine psb_z_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_transc_1mat + implicit none + class(psb_zspmat_type), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_transc_1mat + + + +subroutine psb_z_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_z_transc_2mat + implicit none + class(psb_zspmat_type), intent(out) :: a + class(psb_zspmat_type), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + +#if defined(HAVE_MOLD) + allocate(a%a,mold=b%a,stat=info) +#else + call b%a%mold(a%a,info) +#endif + 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_transc_2mat + + + + +subroutine psb_z_reinit(a,clear) + use psb_z_mat_mod, psb_protect_name => psb_z_reinit + use psb_error_mod + implicit none + + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + +end subroutine psb_z_reinit + + + + +! == =================================== +! +! +! +! Computational routines +! +! +! +! +! +! +! == =================================== + + +subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csmm + implicit none + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 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%csmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csmm + + +subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_z_mat_mod, psb_protect_name => psb_z_csmv + implicit none + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 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%csmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_csmv + + +subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cssm + implicit none + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 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%cssm(alpha,x,beta,y,info,trans,scale,d) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_cssm + + +subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) + use psb_error_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cssv + implicit none + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 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%cssm(alpha,x,beta,y,info,trans,scale,d) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_cssv + + + +function psb_z_csnmi(a) result(res) + use psb_z_mat_mod, psb_protect_name => psb_z_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_zspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end function psb_z_csnmi + + +subroutine psb_z_get_diag(a,d,info) + use psb_z_mat_mod, psb_protect_name => psb_z_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_get_diag + + +subroutine psb_z_scal(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_scal + implicit none + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_scal + + +subroutine psb_z_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_scals + implicit none + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 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 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_scals + + + diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 index 37e1c97e..be7fd55b 100644 --- a/base/tools/psb_casb.f90 +++ b/base/tools/psb_casb.f90 @@ -63,7 +63,7 @@ subroutine psb_casb(x, desc_a, info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index 591233ed..d56c2bef 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -285,12 +285,11 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) end if ! allocate work vector - allocate(desc%matrix_data(psb_mdata_size_),& - &temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),& + allocate(temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),& & stat=info) if (info == psb_success_) then desc%lprm(1) = 0 - desc%matrix_data(:) = 0 +!!$ desc%matrix_data(:) = 0 end if if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -300,11 +299,11 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) endif temp_ovrlap(:) = -1 - desc%matrix_data(psb_m_) = m - desc%matrix_data(psb_n_) = n - ! This has to be set BEFORE any call to SET_BLD - desc%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) +!!$ desc%matrix_data(psb_m_) = m +!!$ desc%matrix_data(psb_n_) = n +!!$ ! This has to be set BEFORE any call to SET_BLD +!!$ desc%matrix_data(psb_ctxt_) = ictxt +!!$ call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) if (debug_level >= psb_debug_ext_) & @@ -372,9 +371,9 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) goto 9999 endif - ! set fields in desc%MATRIX_DATA.... - desc%matrix_data(psb_n_row_) = loc_row - desc%matrix_data(psb_n_col_) = loc_row +!!$ ! set fields in desc%MATRIX_DATA.... +!!$ desc%matrix_data(psb_n_row_) = loc_row +!!$ desc%matrix_data(psb_n_col_) = loc_row !!$ call psb_realloc(max(1,loc_row/2),desc%halo_index, info) !!$ if (info == psb_success_) call psb_realloc(1,desc%ext_index, info) diff --git a/base/tools/psb_cd_set_bld.f90 b/base/tools/psb_cd_set_bld.f90 index 9dd1d320..c22a7741 100644 --- a/base/tools/psb_cd_set_bld.f90 +++ b/base/tools/psb_cd_set_bld.f90 @@ -39,7 +39,7 @@ subroutine psb_cd_set_ovl_bld(desc,info) if (info == psb_success_) then if (desc%indxmap%row_extendable()) then call desc%indxmap%set_state(psb_desc_ovl_bld_) - desc%matrix_data(psb_dec_type_) = psb_desc_ovl_bld_ +!!$ desc%matrix_data(psb_dec_type_) = psb_desc_ovl_bld_ else info = psb_err_invalid_cd_state_ end if @@ -73,7 +73,7 @@ subroutine psb_cd_set_bld(desc,info) if (psb_is_asb_desc(desc)) then end if - desc%matrix_data(psb_dec_type_) = psb_desc_bld_ +!!$ desc%matrix_data(psb_dec_type_) = psb_desc_bld_ call desc%indxmap%set_state(psb_desc_bld_) if (debug) write(psb_err_unit,*) me,'SET_BLD: done' diff --git a/base/tools/psb_cdall.f90 b/base/tools/psb_cdall.f90 index ef0dc225..d6cdbe9f 100644 --- a/base/tools/psb_cdall.f90 +++ b/base/tools/psb_cdall.f90 @@ -128,12 +128,12 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche else if (present(nl)) then - allocate(desc%matrix_data(psb_mdata_size_)) - desc%matrix_data(psb_m_) = nl - call psb_sum(ictxt,desc%matrix_data(psb_m_)) - desc%matrix_data(psb_n_) = desc%matrix_data(psb_m_) - desc%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) +!!$ allocate(desc%matrix_data(psb_mdata_size_)) +!!$ desc%matrix_data(psb_m_) = nl +!!$ call psb_sum(ictxt,desc%matrix_data(psb_m_)) +!!$ desc%matrix_data(psb_n_) = desc%matrix_data(psb_m_) +!!$ desc%matrix_data(psb_ctxt_) = ictxt +!!$ call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) @@ -176,12 +176,12 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche call psb_errpush(info,name,a_err='psb_realloc') Goto 999 end if - desc%matrix_data(psb_pnt_h_) = 1 +!!$ desc%matrix_data(psb_pnt_h_) = 1 desc%halo_index(:) = -1 desc%ext_index(:) = -1 call psb_cd_set_bld(desc,info) - desc%matrix_data(psb_n_row_) = desc%indxmap%get_lr() - desc%matrix_data(psb_n_col_) = desc%indxmap%get_lc() +!!$ desc%matrix_data(psb_n_row_) = desc%indxmap%get_lr() +!!$ desc%matrix_data(psb_n_col_) = desc%indxmap%get_lc() if (info /= psb_success_) goto 999 call psb_erractionrestore(err_act) diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index f806f383..b70a34bb 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -125,9 +125,10 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) ! count local rows number loc_row = max(1,(m+np-1)/np) ! allocate work vector - allocate(desc%matrix_data(psb_mdata_size_),& - & temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info) - desc%matrix_data(:) = 0 +!!$ allocate(desc%matrix_data(psb_mdata_size_),& +!!$ & temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info) +!!$ desc%matrix_data(:) = 0 + allocate(temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -136,11 +137,11 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) call psb_errpush(err,name,int_err,a_err='integer') goto 9999 endif - desc%matrix_data(psb_m_) = m - desc%matrix_data(psb_n_) = n - ! This has to be set BEFORE any call to SET_BLD - desc%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) +!!$ desc%matrix_data(psb_m_) = m +!!$ desc%matrix_data(psb_n_) = n +!!$ ! This has to be set BEFORE any call to SET_BLD +!!$ desc%matrix_data(psb_ctxt_) = ictxt +!!$ call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) if (debug_level >= psb_debug_ext_) & @@ -288,9 +289,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) Goto 9999 endif - ! set fields in desc%MATRIX_DATA.... - desc%matrix_data(psb_n_row_) = loc_row - desc%matrix_data(psb_n_col_) = loc_row +!!$ ! set fields in desc%MATRIX_DATA.... +!!$ desc%matrix_data(psb_n_row_) = loc_row +!!$ desc%matrix_data(psb_n_col_) = loc_row !!$ write(0,*) me,'CDALS: after init ', & !!$ & desc%indxmap%get_gr(), & diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index 4663c049..b22b0533 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -137,22 +137,18 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) ! count local rows number loc_row = max(1,(m+np-1)/np) ! allocate work vector - allocate(desc%matrix_data(psb_mdata_size_),& - &temp_ovrlap(max(1,2*loc_row)),stat=info) - if (info == psb_success_) then - desc%matrix_data(:) = 0 - end if + allocate(temp_ovrlap(2),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ int_err(1)=2*m+psb_mdata_size_ call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 endif - desc%matrix_data(psb_m_) = m - desc%matrix_data(psb_n_) = n - ! This has to be set BEFORE any call to SET_BLD - desc%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) +!!$ desc%matrix_data(psb_m_) = m +!!$ desc%matrix_data(psb_n_) = n +!!$ ! This has to be set BEFORE any call to SET_BLD +!!$ desc%matrix_data(psb_ctxt_) = ictxt +!!$ call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info @@ -215,10 +211,10 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) goto 9999 endif - ! set fields in desc%MATRIX_DATA.... - desc%matrix_data(psb_n_row_) = loc_row - desc%matrix_data(psb_n_col_) = loc_row - +!!$ ! set fields in desc%MATRIX_DATA.... +!!$ desc%matrix_data(psb_n_row_) = loc_row +!!$ desc%matrix_data(psb_n_col_) = loc_row +!!$ if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_cdcpy.f90 b/base/tools/psb_cdcpy.F90 similarity index 95% rename from base/tools/psb_cdcpy.f90 rename to base/tools/psb_cdcpy.F90 index 9baaeb63..05a0ef4c 100644 --- a/base/tools/psb_cdcpy.f90 +++ b/base/tools/psb_cdcpy.F90 @@ -73,7 +73,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) goto 9999 endif - call psb_safe_ab_cpy(desc_in%matrix_data,desc_out%matrix_data,info) +!!$ call psb_safe_ab_cpy(desc_in%matrix_data,desc_out%matrix_data,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%halo_index,desc_out%halo_index,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ext_index,desc_out%ext_index,info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovrlap_index,& @@ -85,17 +85,19 @@ subroutine psb_cdcpy(desc_in, desc_out, info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%idx_space,desc_out%idx_space,info) if (allocated(desc_in%indxmap)) then + !!$ if (allocated(desc_out%indxmap)) then !!$ ! This should never happen !!$ call desc_out%indxmap%free() !!$ deallocate(desc_out%indxmap) !!$ end if !!$ write(debug_unit,*) me,' ',trim(name),': Calling allocate(SOURCE = )' -!!$ if (info == psb_success_)& -!!$ & allocate(desc_out%indxmap, source=desc_in%indxmap, stat=info) - +#ifdef SOURCE_WORKAROUND call desc_in%indxmap%clone(desc_out%indxmap,info) - +#else + if (info == psb_success_)& + & allocate(desc_out%indxmap, source=desc_in%indxmap, stat=info) +#endif end if diff --git a/base/tools/psb_cdprt.f90 b/base/tools/psb_cdprt.f90 index 952718d5..bd7b8d9e 100644 --- a/base/tools/psb_cdprt.f90 +++ b/base/tools/psb_cdprt.f90 @@ -61,12 +61,15 @@ subroutine psb_cdprt(iout,desc_p,glob,short) else lshort = .true. endif + write(0,*) 'To be reimplemented ye' + return if (.not.lglob) then - write(iout,*) 'Communication descriptor:',desc_p%matrix_data(1:10) - m=desc_p%matrix_data(psb_m_) - n_row=desc_p%matrix_data(psb_n_row_) - n_col=desc_p%matrix_data(psb_n_col_) +!!$ write(iout,*) 'Communication descriptor:',desc_p%matrix_data(1:10) +!!$ m=desc_p%matrix_data(psb_m_) +!!$ n_row=desc_p%matrix_data(psb_n_row_) +!!$ n_col=desc_p%matrix_data(psb_n_col_) + !!$ if (.not.lshort) & !!$ & write(iout,*) 'Loc_to_glob ',desc_p%idxmap%loc_to_glob(1:n_row), ': ',& !!$ & desc_p%idxmap%loc_to_glob(n_row+1:n_col) @@ -139,10 +142,10 @@ subroutine psb_cdprt(iout,desc_p,glob,short) else if (lglob) then - write(iout,*) 'Communication descriptor:',desc_p%matrix_data(1:10) - m=desc_p%matrix_data(psb_m_) - n_row=desc_p%matrix_data(psb_n_row_) - n_col=desc_p%matrix_data(psb_n_col_) +!!$ write(iout,*) 'Communication descriptor:',desc_p%matrix_data(1:10) +!!$ m=desc_p%matrix_data(psb_m_) +!!$ n_row=desc_p%matrix_data(psb_n_row_) +!!$ n_col=desc_p%matrix_data(psb_n_col_) if (.not.lshort) then !!$ write(iout,*) 'Loc_to_glob ' !!$ do i=1, n_row diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index ad3d2d21..1c44c314 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -174,24 +174,24 @@ subroutine psb_cdrep(m, ictxt, desc, info) !count local rows number ! allocate work vector - allocate(desc%matrix_data(psb_mdata_size_),& - & desc%ovrlap_elem(0,3),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=2*m+psb_mdata_size_+1 - call psb_errpush(info,name,i_err=int_err,a_err='integer') - goto 9999 - endif - ! If the index space is replicated there's no point in not having - ! the full map on the current process. - - desc%matrix_data(psb_m_) = m - desc%matrix_data(psb_n_) = n - desc%matrix_data(psb_n_row_) = m - desc%matrix_data(psb_n_col_) = n - desc%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) - desc%matrix_data(psb_dec_type_) = psb_desc_bld_ +!!$ allocate(desc%matrix_data(psb_mdata_size_),& +!!$ & desc%ovrlap_elem(0,3),stat=info) +!!$ if (info /= psb_success_) then +!!$ info=psb_err_alloc_request_ +!!$ int_err(1)=2*m+psb_mdata_size_+1 +!!$ call psb_errpush(info,name,i_err=int_err,a_err='integer') +!!$ goto 9999 +!!$ endif +!!$ ! If the index space is replicated there's no point in not having +!!$ ! the full map on the current process. +!!$ +!!$ desc%matrix_data(psb_m_) = m +!!$ desc%matrix_data(psb_n_) = n +!!$ desc%matrix_data(psb_n_row_) = m +!!$ desc%matrix_data(psb_n_col_) = n +!!$ desc%matrix_data(psb_ctxt_) = ictxt +!!$ call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) +!!$ desc%matrix_data(psb_dec_type_) = psb_desc_bld_ allocate(psb_repl_map :: desc%indxmap, stat=info) @@ -208,7 +208,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) tovr = -1 call psi_bld_tmpovrl(tovr,desc,info) - desc%matrix_data(psb_dec_type_) = psb_desc_bld_ +!!$ desc%matrix_data(psb_dec_type_) = psb_desc_bld_ if (debug_level >= psb_debug_ext_) & diff --git a/base/tools/psb_cfree.f90 b/base/tools/psb_cfree.f90 index 1cd90585..8ed7930e 100644 --- a/base/tools/psb_cfree.f90 +++ b/base/tools/psb_cfree.f90 @@ -56,10 +56,10 @@ subroutine psb_cfree(x, desc_a, info) info=psb_success_ call psb_erractionsave(err_act) name='psb_cfree' - if (.not.allocated(desc_a%matrix_data)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return end if ictxt=psb_cd_get_context(desc_a) @@ -128,7 +128,7 @@ subroutine psb_cfreev(x, desc_a, info) name='psb_cfreev' - if (.not.allocated(desc_a%matrix_data)) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index 80be9758..6a08a67c 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -76,7 +76,7 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_cinsvi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return @@ -122,13 +122,13 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl) call psb_errpush(info,name) goto 9999 endif - + if (present(dupl)) then dupl_ = dupl else dupl_ = psb_dupl_ovwrt_ endif - + call psi_idx_cnv(m,irw,irl,desc_a,info,owned=.true.) select case(dupl_) @@ -150,8 +150,8 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl) !loop over all val's rows if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x + ! this row belongs to me + ! copy i-th row of block val in x x(irl(i)) = x(irl(i)) + val(i) end if enddo @@ -257,7 +257,7 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_cinsi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return diff --git a/base/tools/psb_cspfree.f90 b/base/tools/psb_cspfree.f90 index e739ec1f..0f11d0a2 100644 --- a/base/tools/psb_cspfree.f90 +++ b/base/tools/psb_cspfree.f90 @@ -56,7 +56,7 @@ subroutine psb_cspfree(a, desc_a,info) name = 'psb_cspfree' call psb_erractionsave(err_act) - if (.not.allocated(desc_a%matrix_data)) then + if (.not.psb_is_ok_desc(desc_a)) then info = psb_err_forgot_spall_ call psb_errpush(info,name) return diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index 160a0aa4..b0a20a0f 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -63,7 +63,7 @@ subroutine psb_dasb(x, desc_a, info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_dfree.f90 b/base/tools/psb_dfree.f90 index 0e514a5d..a857a68e 100644 --- a/base/tools/psb_dfree.f90 +++ b/base/tools/psb_dfree.f90 @@ -56,7 +56,7 @@ subroutine psb_dfree(x, desc_a, info) info=psb_success_ call psb_erractionsave(err_act) name='psb_dfree' - if (.not.allocated(desc_a%matrix_data)) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 @@ -126,7 +126,7 @@ subroutine psb_dfreev(x, desc_a, info) call psb_erractionsave(err_act) name='psb_dfreev' - if (.not.allocated(desc_a%matrix_data)) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_forgot_spall_ call psb_errpush(info,name) return diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index 55c8c89a..5bd0fdf9 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -75,7 +75,7 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_dinsvi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return @@ -257,7 +257,7 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_dinsi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return diff --git a/base/tools/psb_dspfree.f90 b/base/tools/psb_dspfree.f90 index 44751c9e..cede6830 100644 --- a/base/tools/psb_dspfree.f90 +++ b/base/tools/psb_dspfree.f90 @@ -56,7 +56,7 @@ subroutine psb_dspfree(a, desc_a,info) name = 'psb_dspfree' call psb_erractionsave(err_act) - if (.not.allocated(desc_a%matrix_data)) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_forgot_spall_ call psb_errpush(info,name) return diff --git a/base/tools/psb_glob_to_loc.f90 b/base/tools/psb_glob_to_loc.f90 index 70439e04..955a5512 100644 --- a/base/tools/psb_glob_to_loc.f90 +++ b/base/tools/psb_glob_to_loc.f90 @@ -180,7 +180,7 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) !....locals.... integer :: n character :: act - integer :: err_act, dectype + integer :: err_act logical :: owned_ integer, parameter :: zero=0 character(len=20) :: name @@ -189,11 +189,10 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'glob_to_loc' - ictxt = desc_a%matrix_data(psb_ctxt_) + ictxt = psb_cd_get_context(desc_a) call psb_info(ictxt,iam,np) call psb_erractionsave(err_act) - dectype = desc_a%matrix_data(psb_dec_type_) if (present(iact)) then act=iact else diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index aaaf7045..35361541 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -63,7 +63,7 @@ subroutine psb_iasb(x, desc_a, info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_icdasb.F90 b/base/tools/psb_icdasb.F90 index 5d6e9efc..b25a983e 100644 --- a/base/tools/psb_icdasb.F90 +++ b/base/tools/psb_icdasb.F90 @@ -148,10 +148,10 @@ subroutine psb_icdasb(desc_a,info,ext_hv) info = psb_success_ end if - desc_a%matrix_data(psb_n_row_) = desc_a%indxmap%get_lr() - desc_a%matrix_data(psb_n_col_) = desc_a%indxmap%get_lc() - ! Ok, register into MATRIX_DATA - desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ +!!$ desc_a%matrix_data(psb_n_row_) = desc_a%indxmap%get_lr() +!!$ desc_a%matrix_data(psb_n_col_) = desc_a%indxmap%get_lc() +!!$ ! Ok, register into MATRIX_DATA +!!$ desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ else info = psb_err_spmat_invalid_state_ diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index f7328296..c8d5a088 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -57,7 +57,7 @@ subroutine psb_ifree(x, desc_a, info) call psb_erractionsave(err_act) name = 'psb_ifree' - if (.not.allocated(desc_a%matrix_data)) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_forgot_spall_ call psb_errpush(info,name) return @@ -157,11 +157,11 @@ subroutine psb_ifreev(x, desc_a,info) call psb_erractionsave(err_act) name = 'psb_ifreev' - - if (.not.allocated(desc_a%matrix_data)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return end if ictxt=psb_cd_get_context(desc_a) @@ -174,26 +174,26 @@ subroutine psb_ifreev(x, desc_a,info) endif if (.not.allocated(x)) then - info=psb_err_forgot_geall_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_forgot_geall_ + call psb_errpush(info,name) + goto 9999 end if - + !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then info=psb_err_alloc_dealloc_ call psb_errpush(info,name) endif - + call psb_erractionrestore(err_act) return 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index 923728c5..ef5b8424 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -75,7 +75,7 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_insvi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return @@ -256,7 +256,7 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_iinsi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index 7bbcf74d..aaa315a8 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -63,7 +63,7 @@ subroutine psb_sasb(x, desc_a, info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_sfree.f90 b/base/tools/psb_sfree.f90 index 7feb6bcf..39a4d33e 100644 --- a/base/tools/psb_sfree.f90 +++ b/base/tools/psb_sfree.f90 @@ -56,10 +56,10 @@ subroutine psb_sfree(x, desc_a, info) info=psb_success_ call psb_erractionsave(err_act) name='psb_sfree' - if (.not.allocated(desc_a%matrix_data)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 end if ictxt = psb_cd_get_context(desc_a) @@ -73,9 +73,9 @@ subroutine psb_sfree(x, desc_a, info) endif if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 end if !deallocate x @@ -93,8 +93,8 @@ subroutine psb_sfree(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return @@ -126,10 +126,10 @@ subroutine psb_sfreev(x, desc_a, info) call psb_erractionsave(err_act) name='psb_sfreev' - if (.not.allocated(desc_a%matrix_data)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return end if ictxt = psb_cd_get_context(desc_a) @@ -141,9 +141,9 @@ subroutine psb_sfreev(x, desc_a, info) endif if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 end if !deallocate x @@ -159,8 +159,8 @@ subroutine psb_sfreev(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index efc2dc79..8416501a 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -75,7 +75,7 @@ subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_sinsvi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return @@ -257,7 +257,7 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_sinsi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return diff --git a/base/tools/psb_sspfree.f90 b/base/tools/psb_sspfree.f90 index 76f4ad46..e00129bd 100644 --- a/base/tools/psb_sspfree.f90 +++ b/base/tools/psb_sspfree.f90 @@ -56,7 +56,7 @@ subroutine psb_sspfree(a, desc_a,info) name = 'psb_sspfree' call psb_erractionsave(err_act) - if (.not.allocated(desc_a%matrix_data)) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_forgot_spall_ call psb_errpush(info,name) return diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index 74ca30da..20ef5bb2 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -63,7 +63,7 @@ subroutine psb_zasb(x, desc_a, info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then info=psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_zfree.f90 b/base/tools/psb_zfree.f90 index 79dbb572..e0ecca18 100644 --- a/base/tools/psb_zfree.f90 +++ b/base/tools/psb_zfree.f90 @@ -56,10 +56,10 @@ subroutine psb_zfree(x, desc_a, info) info=psb_success_ call psb_erractionsave(err_act) name='psb_zfree' - if (.not.allocated(desc_a%matrix_data)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return end if ictxt=psb_cd_get_context(desc_a) @@ -73,9 +73,9 @@ subroutine psb_zfree(x, desc_a, info) endif if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 end if !deallocate x @@ -85,7 +85,7 @@ subroutine psb_zfree(x, desc_a, info) call psb_errpush(info,name) goto 9999 endif - + call psb_erractionrestore(err_act) return @@ -93,8 +93,8 @@ subroutine psb_zfree(x, desc_a, info) 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return + call psb_error(ictxt) + return end if return @@ -128,34 +128,34 @@ subroutine psb_zfreev(x, desc_a, info) name='psb_zfreev' - if (.not.allocated(desc_a%matrix_data)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 end if ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 endif if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 end if !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) endif - + call psb_erractionrestore(err_act) return @@ -163,9 +163,9 @@ subroutine psb_zfreev(x, desc_a, info) call psb_erractionrestore(err_act) if (err_act == psb_act_ret_) then - return + return else - call psb_error(ictxt) + call psb_error(ictxt) end if return diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index ff0b5f6f..59c19302 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -76,7 +76,7 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_zinsvi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return @@ -257,7 +257,7 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl) call psb_erractionsave(err_act) name = 'psb_zinsi' - if ((.not.allocated(desc_a%matrix_data))) then + if (.not.psb_is_ok_desc(desc_a)) then int_err(1)=3110 call psb_errpush(info,name) return diff --git a/base/tools/psb_zspfree.f90 b/base/tools/psb_zspfree.f90 index b44bc423..1cf86153 100644 --- a/base/tools/psb_zspfree.f90 +++ b/base/tools/psb_zspfree.f90 @@ -56,7 +56,7 @@ subroutine psb_zspfree(a, desc_a,info) name = 'psb_zspfree' call psb_erractionsave(err_act) - if (.not.allocated(desc_a%matrix_data)) then + if (.not.psb_is_ok_desc(desc_a)) then info = psb_err_forgot_spall_ call psb_errpush(info,name) return