From 45414785de14dce7b5c00f44c6e438914b113795 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sun, 2 Jan 2011 18:52:35 +0000 Subject: [PATCH] psblas3: base/serial/f03/Makefile base/serial/f03/psb_base_mat_impl.f90 base/serial/f03/psb_c_base_mat_impl.f90 base/serial/f03/psb_c_coo_impl.f90 base/serial/f03/psb_c_csc_impl.f90 base/serial/f03/psb_c_csr_impl.f90 base/serial/f03/psb_c_mat_impl.F90 base/serial/f03/psb_d_base_mat_impl.f90 base/serial/f03/psb_d_coo_impl.f90 base/serial/f03/psb_d_csc_impl.f90 base/serial/f03/psb_d_csr_impl.f90 base/serial/f03/psb_d_mat_impl.F90 base/serial/f03/psb_s_base_mat_impl.f90 base/serial/f03/psb_s_coo_impl.f90 base/serial/f03/psb_s_csc_impl.f90 base/serial/f03/psb_s_csr_impl.f90 base/serial/f03/psb_s_mat_impl.F90 base/serial/f03/psb_z_base_mat_impl.f90 base/serial/f03/psb_z_coo_impl.f90 base/serial/f03/psb_z_csc_impl.f90 base/serial/f03/psb_z_csr_impl.f90 base/serial/f03/psb_z_mat_impl.F90 Change name of f03 subdir, step 1 --- base/serial/f03/Makefile | 44 - base/serial/f03/psb_base_mat_impl.f90 | 337 --- base/serial/f03/psb_c_base_mat_impl.f90 | 1102 -------- base/serial/f03/psb_c_coo_impl.f90 | 3234 ---------------------- base/serial/f03/psb_c_csc_impl.f90 | 3038 --------------------- base/serial/f03/psb_c_csr_impl.f90 | 2848 -------------------- base/serial/f03/psb_c_mat_impl.F90 | 2004 -------------- base/serial/f03/psb_d_base_mat_impl.f90 | 1236 --------- base/serial/f03/psb_d_coo_impl.f90 | 3280 ----------------------- base/serial/f03/psb_d_csc_impl.f90 | 2911 -------------------- base/serial/f03/psb_d_csr_impl.f90 | 2898 -------------------- base/serial/f03/psb_d_mat_impl.F90 | 2238 ---------------- base/serial/f03/psb_s_base_mat_impl.f90 | 1102 -------- base/serial/f03/psb_s_coo_impl.f90 | 3033 --------------------- base/serial/f03/psb_s_csc_impl.f90 | 2675 ------------------ base/serial/f03/psb_s_csr_impl.f90 | 2656 ------------------ base/serial/f03/psb_s_mat_impl.F90 | 2003 -------------- base/serial/f03/psb_z_base_mat_impl.f90 | 1103 -------- base/serial/f03/psb_z_coo_impl.f90 | 3233 ---------------------- base/serial/f03/psb_z_csc_impl.f90 | 3038 --------------------- base/serial/f03/psb_z_csr_impl.f90 | 2847 -------------------- base/serial/f03/psb_z_mat_impl.F90 | 2002 -------------- 22 files changed, 48862 deletions(-) delete mode 100644 base/serial/f03/Makefile delete mode 100644 base/serial/f03/psb_base_mat_impl.f90 delete mode 100644 base/serial/f03/psb_c_base_mat_impl.f90 delete mode 100644 base/serial/f03/psb_c_coo_impl.f90 delete mode 100644 base/serial/f03/psb_c_csc_impl.f90 delete mode 100644 base/serial/f03/psb_c_csr_impl.f90 delete mode 100644 base/serial/f03/psb_c_mat_impl.F90 delete mode 100644 base/serial/f03/psb_d_base_mat_impl.f90 delete mode 100644 base/serial/f03/psb_d_coo_impl.f90 delete mode 100644 base/serial/f03/psb_d_csc_impl.f90 delete mode 100644 base/serial/f03/psb_d_csr_impl.f90 delete mode 100644 base/serial/f03/psb_d_mat_impl.F90 delete mode 100644 base/serial/f03/psb_s_base_mat_impl.f90 delete mode 100644 base/serial/f03/psb_s_coo_impl.f90 delete mode 100644 base/serial/f03/psb_s_csc_impl.f90 delete mode 100644 base/serial/f03/psb_s_csr_impl.f90 delete mode 100644 base/serial/f03/psb_s_mat_impl.F90 delete mode 100644 base/serial/f03/psb_z_base_mat_impl.f90 delete mode 100644 base/serial/f03/psb_z_coo_impl.f90 delete mode 100644 base/serial/f03/psb_z_csc_impl.f90 delete mode 100644 base/serial/f03/psb_z_csr_impl.f90 delete mode 100644 base/serial/f03/psb_z_mat_impl.F90 diff --git a/base/serial/f03/Makefile b/base/serial/f03/Makefile deleted file mode 100644 index 68d82f50..00000000 --- a/base/serial/f03/Makefile +++ /dev/null @@ -1,44 +0,0 @@ -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/f03/psb_base_mat_impl.f90 b/base/serial/f03/psb_base_mat_impl.f90 deleted file mode 100644 index 514b0d98..00000000 --- a/base/serial/f03/psb_base_mat_impl.f90 +++ /dev/null @@ -1,337 +0,0 @@ -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/f03/psb_c_base_mat_impl.f90 b/base/serial/f03/psb_c_base_mat_impl.f90 deleted file mode 100644 index 4e8ce78f..00000000 --- a/base/serial/f03/psb_c_base_mat_impl.f90 +++ /dev/null @@ -1,1102 +0,0 @@ -! == ================================== -! -! -! -! 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/f03/psb_c_coo_impl.f90 b/base/serial/f03/psb_c_coo_impl.f90 deleted file mode 100644 index 61158f65..00000000 --- a/base/serial/f03/psb_c_coo_impl.f90 +++ /dev/null @@ -1,3234 +0,0 @@ - -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/f03/psb_c_csc_impl.f90 b/base/serial/f03/psb_c_csc_impl.f90 deleted file mode 100644 index 326d6318..00000000 --- a/base/serial/f03/psb_c_csc_impl.f90 +++ /dev/null @@ -1,3038 +0,0 @@ -! == =================================== -! -! -! -! 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/f03/psb_c_csr_impl.f90 b/base/serial/f03/psb_c_csr_impl.f90 deleted file mode 100644 index 53b6381f..00000000 --- a/base/serial/f03/psb_c_csr_impl.f90 +++ /dev/null @@ -1,2848 +0,0 @@ - -! == =================================== -! -! -! -! 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/f03/psb_c_mat_impl.F90 b/base/serial/f03/psb_c_mat_impl.F90 deleted file mode 100644 index f598148f..00000000 --- a/base/serial/f03/psb_c_mat_impl.F90 +++ /dev/null @@ -1,2004 +0,0 @@ -! == =================================== -! -! -! -! 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/f03/psb_d_base_mat_impl.f90 b/base/serial/f03/psb_d_base_mat_impl.f90 deleted file mode 100644 index a6ad8394..00000000 --- a/base/serial/f03/psb_d_base_mat_impl.f90 +++ /dev/null @@ -1,1236 +0,0 @@ -! == ================================== -! -! -! -! 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/f03/psb_d_coo_impl.f90 b/base/serial/f03/psb_d_coo_impl.f90 deleted file mode 100644 index 8d22c396..00000000 --- a/base/serial/f03/psb_d_coo_impl.f90 +++ /dev/null @@ -1,3280 +0,0 @@ - -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/f03/psb_d_csc_impl.f90 b/base/serial/f03/psb_d_csc_impl.f90 deleted file mode 100644 index 9456db1b..00000000 --- a/base/serial/f03/psb_d_csc_impl.f90 +++ /dev/null @@ -1,2911 +0,0 @@ - -! == =================================== -! -! -! -! 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/f03/psb_d_csr_impl.f90 b/base/serial/f03/psb_d_csr_impl.f90 deleted file mode 100644 index b779f5b0..00000000 --- a/base/serial/f03/psb_d_csr_impl.f90 +++ /dev/null @@ -1,2898 +0,0 @@ - -! == =================================== -! -! -! -! 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/f03/psb_d_mat_impl.F90 b/base/serial/f03/psb_d_mat_impl.F90 deleted file mode 100644 index 883eb136..00000000 --- a/base/serial/f03/psb_d_mat_impl.F90 +++ /dev/null @@ -1,2238 +0,0 @@ -! == =================================== -! -! -! -! 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/f03/psb_s_base_mat_impl.f90 b/base/serial/f03/psb_s_base_mat_impl.f90 deleted file mode 100644 index e6ad064e..00000000 --- a/base/serial/f03/psb_s_base_mat_impl.f90 +++ /dev/null @@ -1,1102 +0,0 @@ -! == ================================== -! -! -! -! 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/f03/psb_s_coo_impl.f90 b/base/serial/f03/psb_s_coo_impl.f90 deleted file mode 100644 index 5908fa75..00000000 --- a/base/serial/f03/psb_s_coo_impl.f90 +++ /dev/null @@ -1,3033 +0,0 @@ - -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/f03/psb_s_csc_impl.f90 b/base/serial/f03/psb_s_csc_impl.f90 deleted file mode 100644 index 964a17d5..00000000 --- a/base/serial/f03/psb_s_csc_impl.f90 +++ /dev/null @@ -1,2675 +0,0 @@ - -! == =================================== -! -! -! -! 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/f03/psb_s_csr_impl.f90 b/base/serial/f03/psb_s_csr_impl.f90 deleted file mode 100644 index f2e743ea..00000000 --- a/base/serial/f03/psb_s_csr_impl.f90 +++ /dev/null @@ -1,2656 +0,0 @@ - -! == =================================== -! -! -! -! 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/f03/psb_s_mat_impl.F90 b/base/serial/f03/psb_s_mat_impl.F90 deleted file mode 100644 index 1cc31802..00000000 --- a/base/serial/f03/psb_s_mat_impl.F90 +++ /dev/null @@ -1,2003 +0,0 @@ -! == =================================== -! -! -! -! 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/f03/psb_z_base_mat_impl.f90 b/base/serial/f03/psb_z_base_mat_impl.f90 deleted file mode 100644 index 9fd6b20b..00000000 --- a/base/serial/f03/psb_z_base_mat_impl.f90 +++ /dev/null @@ -1,1103 +0,0 @@ -! == ================================== -! -! -! -! 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/f03/psb_z_coo_impl.f90 b/base/serial/f03/psb_z_coo_impl.f90 deleted file mode 100644 index b8139250..00000000 --- a/base/serial/f03/psb_z_coo_impl.f90 +++ /dev/null @@ -1,3233 +0,0 @@ - -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/f03/psb_z_csc_impl.f90 b/base/serial/f03/psb_z_csc_impl.f90 deleted file mode 100644 index 4c84098c..00000000 --- a/base/serial/f03/psb_z_csc_impl.f90 +++ /dev/null @@ -1,3038 +0,0 @@ - -! == =================================== -! -! -! -! 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/f03/psb_z_csr_impl.f90 b/base/serial/f03/psb_z_csr_impl.f90 deleted file mode 100644 index bb8f66f2..00000000 --- a/base/serial/f03/psb_z_csr_impl.f90 +++ /dev/null @@ -1,2847 +0,0 @@ - - -! == =================================== -! -! -! -! 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/f03/psb_z_mat_impl.F90 b/base/serial/f03/psb_z_mat_impl.F90 deleted file mode 100644 index 7873074d..00000000 --- a/base/serial/f03/psb_z_mat_impl.F90 +++ /dev/null @@ -1,2002 +0,0 @@ -! == =================================== -! -! -! -! 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 - - -