diff --git a/base/modules/Makefile b/base/modules/Makefile index a5a260e3..97910be0 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -8,8 +8,11 @@ UTIL_MODS = psb_string_mod.o psb_spmat_type.o \ psi_serial_mod.o psi_mod.o psb_ip_reord_mod.o\ psb_check_mod.o psb_gps_mod.o psb_linmap_mod.o psb_hash_mod.o\ psb_base_mat_mod.o psb_mat_mod.o\ + psb_s_base_mat_mod.o psb_s_csr_mat_mod.o psb_s_mat_mod.o \ psb_d_base_mat_mod.o psb_d_csr_mat_mod.o psb_d_mat_mod.o \ - psb_s_base_mat_mod.o psb_s_csr_mat_mod.o psb_s_mat_mod.o + psb_c_base_mat_mod.o psb_c_csr_mat_mod.o psb_c_mat_mod.o \ + psb_z_base_mat_mod.o psb_z_csr_mat_mod.o psb_z_mat_mod.o + MODULES=$(BASIC_MODS) $(UTIL_MODS) @@ -27,11 +30,18 @@ lib: $(BASIC_MODS) blacsmod $(UTIL_MODS) $(OBJS) $(LIBMOD) /bin/cp -p *$(.mod) $(LIBDIR) -psb_base_mat_mod.o: psb_string_mod.o psb_sort_mod.o psb_ip_reord_mod.o psb_error_mod.o psi_serial_mod.o -psb_s_base_mat_mod.o psb_d_base_mat_mod.o: psb_base_mat_mod.o +psb_base_mat_mod.o: psb_string_mod.o psb_sort_mod.o psb_ip_reord_mod.o\ + psb_error_mod.o psi_serial_mod.o +psb_s_base_mat_mod.o psb_d_base_mat_mod.o psb_c_base_mat_mod.o psb_z_base_mat_mod.o: psb_base_mat_mod.o psb_s_mat_mod.o: psb_s_base_mat_mod.o psb_s_csr_mat_mod.o psb_d_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o -psb_mat_mod.o: psb_d_mat_mod.o psb_s_mat_mod.o +psb_c_mat_mod.o: psb_c_base_mat_mod.o psb_c_csr_mat_mod.o +psb_z_mat_mod.o: psb_z_base_mat_mod.o psb_z_csr_mat_mod.o +psb_s_csr_mat_mod.o: psb_s_base_mat_mod.o +psb_d_csr_mat_mod.o: psb_d_base_mat_mod.o +psb_c_csr_mat_mod.o: psb_c_base_mat_mod.o +psb_z_csr_mat_mod.o: psb_z_base_mat_mod.o +psb_mat_mod.o: psb_s_mat_mod.o psb_d_mat_mod.o psb_c_mat_mod.o psb_z_mat_mod.o psb_realloc_mod.o : psb_error_mod.o psb_spmat_type.o : psb_realloc_mod.o psb_error_mod.o psb_const_mod.o psb_string_mod.o psb_sort_mod.o psb_error_mod.o: psb_const_mod.o diff --git a/base/modules/psb_c_base_mat_mod.f03 b/base/modules/psb_c_base_mat_mod.f03 new file mode 100644 index 00000000..fc7585b1 --- /dev/null +++ b/base/modules/psb_c_base_mat_mod.f03 @@ -0,0 +1,2595 @@ +module psb_c_base_mat_mod + + use psb_base_mat_mod + + type, extends(psb_base_sparse_mat) :: psb_c_base_sparse_mat + contains + procedure, pass(a) :: c_base_csmv + procedure, pass(a) :: c_base_csmm + generic, public :: csmm => c_base_csmm, c_base_csmv + procedure, pass(a) :: c_base_cssv + procedure, pass(a) :: c_base_cssm + generic, public :: base_cssm => c_base_cssm, c_base_cssv + procedure, pass(a) :: c_cssv + procedure, pass(a) :: c_cssm + generic, public :: cssm => c_cssm, c_cssv + procedure, pass(a) :: c_scals + procedure, pass(a) :: c_scal + generic, public :: scal => c_scals, c_scal + procedure, pass(a) :: csnmi + procedure, pass(a) :: get_diag + procedure, pass(a) :: csput + + procedure, pass(a) :: c_csgetrow + procedure, pass(a) :: c_csgetblk + generic, public :: csget => c_csgetrow, c_csgetblk + procedure, pass(a) :: csclip + procedure, pass(a) :: cp_to_coo + procedure, pass(a) :: cp_from_coo + procedure, pass(a) :: cp_to_fmt + procedure, pass(a) :: cp_from_fmt + procedure, pass(a) :: mv_to_coo + procedure, pass(a) :: mv_from_coo + procedure, pass(a) :: mv_to_fmt + procedure, pass(a) :: mv_from_fmt + procedure, pass(a) :: c_base_cp_from + generic, public :: cp_from => c_base_cp_from + procedure, pass(a) :: c_base_mv_from + generic, public :: mv_from => c_base_mv_from + end type psb_c_base_sparse_mat + + private :: c_base_csmv, c_base_csmm, c_base_cssv, c_base_cssm,& + & c_scals, c_scal, csnmi, csput, c_csgetrow, c_csgetblk, & + & cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, & + & mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, & + & get_diag, csclip, c_cssv, c_cssm, base_cp_from, base_mv_from + + type, extends(psb_c_base_sparse_mat) :: psb_c_coo_sparse_mat + + integer :: nnz + integer, allocatable :: ia(:), ja(:) + complex(psb_spk_), allocatable :: val(:) + + contains + + procedure, pass(a) :: get_size => c_coo_get_size + procedure, pass(a) :: get_nzeros => c_coo_get_nzeros + procedure, pass(a) :: set_nzeros => c_coo_set_nzeros + procedure, pass(a) :: c_base_csmm => c_coo_csmm + procedure, pass(a) :: c_base_csmv => c_coo_csmv + procedure, pass(a) :: c_base_cssm => c_coo_cssm + procedure, pass(a) :: c_base_cssv => c_coo_cssv + procedure, pass(a) :: c_scals => c_coo_scals + procedure, pass(a) :: c_scal => c_coo_scal + procedure, pass(a) :: csnmi => c_coo_csnmi + procedure, pass(a) :: csput => c_coo_csput + procedure, pass(a) :: get_diag => c_coo_get_diag + procedure, pass(a) :: reallocate_nz => c_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => c_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => c_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => c_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => c_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => c_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => c_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => c_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => c_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => c_mv_coo_from_fmt + procedure, pass(a) :: fix => c_fix_coo + procedure, pass(a) :: free => c_coo_free + procedure, pass(a) :: trim => c_coo_trim + procedure, pass(a) :: c_csgetrow => c_coo_csgetrow + procedure, pass(a) :: csgetptn => c_coo_csgetptn + procedure, pass(a) :: print => c_coo_print + procedure, pass(a) :: get_fmt => c_coo_get_fmt + procedure, pass(a) :: get_nz_row => c_coo_get_nz_row + procedure, pass(a) :: sizeof => c_coo_sizeof + procedure, pass(a) :: reinit => c_coo_reinit + procedure, pass(a) :: c_coo_cp_from + generic, public :: cp_from => c_coo_cp_from + procedure, pass(a) :: c_coo_mv_from + generic, public :: mv_from => c_coo_mv_from + + end type psb_c_coo_sparse_mat + + private :: c_coo_get_nzeros, c_coo_set_nzeros, c_coo_get_diag, & + & c_coo_csmm, c_coo_csmv, c_coo_cssm, c_coo_cssv, c_coo_csnmi, & + & c_coo_csput, c_coo_reallocate_nz, c_coo_allocate_mnnz, & + & c_fix_coo, c_coo_free, c_coo_print, c_coo_get_fmt, & + & c_cp_coo_to_coo, c_cp_coo_from_coo, & + & c_cp_coo_to_fmt, c_cp_coo_from_fmt, & + & c_coo_scals, c_coo_scal, c_coo_csgetrow, c_coo_sizeof, & + & c_coo_csgetptn, c_coo_get_nz_row, c_coo_reinit,& + & c_coo_cp_from, c_coo_mv_from + + + interface + subroutine c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + integer, intent(in) :: nzin,dupl + integer, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), intent(inout) :: val(:) + integer, intent(out) :: nzout, info + integer, intent(in), optional :: idir + end subroutine c_fix_coo_inner + end interface + + interface + subroutine c_fix_coo_impl(a,info,idir) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + end subroutine c_fix_coo_impl + end interface + + interface + subroutine c_cp_coo_to_coo_impl(a,b,info) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine c_cp_coo_to_coo_impl + end interface + + interface + subroutine c_cp_coo_from_coo_impl(a,b,info) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(out) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine c_cp_coo_from_coo_impl + end interface + + interface + subroutine c_cp_coo_to_fmt_impl(a,b,info) + use psb_const_mod + import psb_c_coo_sparse_mat, psb_c_base_sparse_mat + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine c_cp_coo_to_fmt_impl + end interface + + interface + subroutine c_cp_coo_from_fmt_impl(a,b,info) + use psb_const_mod + import psb_c_coo_sparse_mat, psb_c_base_sparse_mat + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine c_cp_coo_from_fmt_impl + end interface + + interface + subroutine c_mv_coo_to_coo_impl(a,b,info) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine c_mv_coo_to_coo_impl + end interface + + interface + subroutine c_mv_coo_from_coo_impl(a,b,info) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine c_mv_coo_from_coo_impl + end interface + + interface + subroutine c_mv_coo_to_fmt_impl(a,b,info) + use psb_const_mod + import psb_c_coo_sparse_mat, psb_c_base_sparse_mat + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine c_mv_coo_to_fmt_impl + end interface + + interface + subroutine c_mv_coo_from_fmt_impl(a,b,info) + use psb_const_mod + import psb_c_coo_sparse_mat, psb_c_base_sparse_mat + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine c_mv_coo_from_fmt_impl + end interface + + + interface + subroutine c_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine c_coo_csput_impl + end interface + + interface + subroutine c_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + use psb_const_mod + import psb_c_coo_sparse_mat + implicit none + 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 + end subroutine c_coo_csgetptn_impl + end interface + + interface + subroutine c_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + use psb_const_mod + import psb_c_coo_sparse_mat + implicit none + + 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 + end subroutine c_coo_csgetrow_impl + end interface + + interface c_coo_cssm_impl + subroutine c_coo_cssv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine c_coo_cssv_impl + subroutine c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine c_coo_cssm_impl + end interface + + interface c_coo_csmm_impl + subroutine c_coo_csmv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine c_coo_csmv_impl + subroutine c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine c_coo_csmm_impl + end interface + + + interface c_coo_csnmi_impl + function c_coo_csnmi_impl(a) result(res) + use psb_const_mod + import psb_c_coo_sparse_mat + class(psb_c_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function c_coo_csnmi_impl + end interface + + +contains + + + !==================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !==================================== + + subroutine cp_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine cp_to_coo + + subroutine cp_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine cp_from_coo + + + subroutine cp_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine cp_to_fmt + + subroutine cp_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine cp_from_fmt + + + subroutine mv_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine mv_to_coo + + subroutine mv_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine mv_from_coo + + + subroutine mv_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine mv_to_fmt + + subroutine mv_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine mv_from_fmt + + subroutine c_base_mv_from(a,b) + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(out) :: a + type(psb_c_base_sparse_mat), intent(inout) :: b + + + ! No new things here, very easy + call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) + + return + + end subroutine c_base_mv_from + + subroutine c_base_cp_from(a,b) + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(out) :: a + type(psb_c_base_sparse_mat), intent(in) :: b + + ! No new things here, very easy + call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) + + return + + end subroutine c_base_cp_from + + + + subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine csput + + subroutine c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_csgetrow + + + + subroutine c_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csgetblk + + + subroutine csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine csclip + + + + !==================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !==================================== + + subroutine c_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_base_csmm + + subroutine c_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + + end subroutine c_base_csmv + + subroutine c_base_cssm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_base_cssm + + subroutine c_base_cssv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='c_base_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_base_cssv + + subroutine c_cssm(alpha,a,x,beta,y,info,trans,side,d) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, side + complex(psb_spk_), intent(in), optional :: d(:) + + complex(psb_spk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: side_ + character(len=20) :: name='c_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(side)) then + side_ = side + else + side_ = 'L' + end if + + if (psb_toupper(side_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == 0)& + & call a%base_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(side_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%base_cssm(cone,x,czero,tmp,info,trans) + + if (info == 0)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == 0)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=side_) + goto 9999 + end if + else + ! Side is ignored in this case + call a%base_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='base_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + end subroutine c_cssm + + subroutine c_cssv(alpha,a,x,beta,y,info,trans,side,d) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, side + complex(psb_spk_), intent(in), optional :: d(:) + + complex(psb_spk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: side_ + character(len=20) :: name='c_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(side)) then + side_ = side + else + side_ = 'L' + end if + + if (psb_toupper(side_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= 0) info = 4000 + if (info == 0) tmp(1:nac) = d(1:nac)*x(1:nac) + if (info == 0)& + & call a%base_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(side_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%base_cssm(cone,x,czero,tmp,info,trans) + + if (info == 0) tmp(1:nar) = d(1:nar)*tmp(1:nar) + if (info == 0)& + & call psb_geaxpby(nar,alpha,tmp,beta,y,info) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=side_) + goto 9999 + end if + else + ! Side is ignored in this case + call a%base_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='base_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + end subroutine c_cssv + + + subroutine c_scals(d,a,info) + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='c_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_scals + + + subroutine c_scal(d,a,info) + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='c_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_scal + + + function csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -sone + + return + + end function csnmi + + subroutine get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + + end subroutine get_diag + + + + + !==================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + !==================================== + + + + function c_coo_sizeof(a) result(res) + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + integer(psb_long_int_k_) :: res + res = 8 + 1 + res = res + 2*psb_sizeof_sp * size(a%val) + res = res + psb_sizeof_int * size(a%ia) + res = res + psb_sizeof_int * size(a%ja) + + end function c_coo_sizeof + + + function c_coo_get_fmt(a) result(res) + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'COO' + end function c_coo_get_fmt + + + function c_coo_get_size(a) result(res) + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + integer :: res + res = -1 + + if (allocated(a%ia)) res = size(a%ia) + if (allocated(a%ja)) then + if (res >= 0) then + res = min(res,size(a%ja)) + else + res = size(a%ja) + end if + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + end function c_coo_get_size + + + function c_coo_get_nzeros(a) result(res) + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + integer :: res + res = a%nnz + end function c_coo_get_nzeros + + + function c_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + + end function c_coo_get_nz_row + + !==================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + !==================================== + + subroutine c_coo_set_nzeros(nz,a) + implicit none + integer, intent(in) :: nz + class(psb_c_coo_sparse_mat), intent(inout) :: a + + a%nnz = nz + + end subroutine c_coo_set_nzeros + + !==================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !==================================== + + + subroutine c_fix_coo(a,info,idir) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + Integer :: err_act + character(len=20) :: name='fix_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_fix_coo_impl(a,info,idir) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + + end subroutine c_fix_coo + + + subroutine c_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_cp_coo_to_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_cp_coo_to_coo + + subroutine c_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(out) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_cp_coo_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_cp_coo_from_coo + + + subroutine c_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_cp_coo_to_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_cp_coo_to_fmt + + subroutine c_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_cp_coo_from_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_cp_coo_from_fmt + + + + subroutine c_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_mv_coo_to_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_mv_coo_to_coo + + subroutine c_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_mv_coo_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_mv_coo_from_coo + + + + subroutine c_coo_cp_from(a,b) + use psb_error_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(out) :: a + type(psb_c_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_cp_coo_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_coo_cp_from + + subroutine c_coo_mv_from(a,b) + use psb_error_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(out) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_mv_coo_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_coo_mv_from + + + subroutine c_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_mv_coo_to_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_mv_coo_to_fmt + + subroutine c_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_mv_coo_from_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_mv_coo_from_fmt + + + + subroutine c_coo_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_c_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='c_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_reallocate_nz + + + subroutine c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='c_coo_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) + info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() + call c_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_csput + + + subroutine c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + call c_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_csgetrow + + + subroutine c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + call c_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_csgetptn + + + subroutine c_coo_free(a) + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0) + call a%set_ncols(0) + + return + + end subroutine c_coo_free + + subroutine c_coo_reinit(a,clear) + use psb_error_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = czero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_reinit + + + subroutine c_coo_trim(a) + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + nz = a%get_nzeros() + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_trim + + subroutine c_coo_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_c_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nc_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nc_ = nz + else + nc_ = max(7*m,7*n,1) + end if + if (nc_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == 0) call psb_realloc(nc_,a%ia,info) + if (info == 0) call psb_realloc(nc_,a%ja,info) + if (info == 0) call psb_realloc(nc_,a%val,info) + if (info == 0) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_allocate_mnnz + + + subroutine c_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + implicit none + + integer, intent(in) :: iout + class(psb_c_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='c_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + + end subroutine c_coo_print + + + + + !==================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !==================================== + + subroutine c_coo_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nac, nar + complex(psb_spk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='c_coo_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + nar = a%get_nrows() + nac = a%get_ncols() + if (size(x) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + + call c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_csmv + + subroutine c_coo_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac + complex(psb_spk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='c_coo_csmm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + nar = a%get_nrows() + nac = a%get_ncols() + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + call c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_csmm + + + subroutine c_coo_cssv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nar, nac + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='c_coo_cssv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + end subroutine c_coo_cssv + + + + subroutine c_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='c_coo_csmm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_cssm + + function c_coo_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + + res = c_coo_csnmi_impl(a) + + return + + end function c_coo_csnmi + + subroutine c_coo_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = czero + + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_get_diag + + subroutine c_coo_scal(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_scal + + subroutine c_coo_scals(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_coo_scals + + +end module psb_c_base_mat_mod + + + diff --git a/base/modules/psb_c_csr_mat_mod.f03 b/base/modules/psb_c_csr_mat_mod.f03 new file mode 100644 index 00000000..db049777 --- /dev/null +++ b/base/modules/psb_c_csr_mat_mod.f03 @@ -0,0 +1,1604 @@ +module psb_c_csr_mat_mod + + use psb_c_base_mat_mod + + type, extends(psb_c_base_sparse_mat) :: psb_c_csr_sparse_mat + + integer, allocatable :: irp(:), ja(:) + complex(psb_spk_), allocatable :: val(:) + + contains + procedure, pass(a) :: get_nzeros => c_csr_get_nzeros + procedure, pass(a) :: get_fmt => c_csr_get_fmt + procedure, pass(a) :: get_diag => c_csr_get_diag + procedure, pass(a) :: c_base_csmm => c_csr_csmm + procedure, pass(a) :: c_base_csmv => c_csr_csmv + procedure, pass(a) :: c_base_cssm => c_csr_cssm + procedure, pass(a) :: c_base_cssv => c_csr_cssv + procedure, pass(a) :: c_scals => c_csr_scals + procedure, pass(a) :: c_scal => c_csr_scal + procedure, pass(a) :: csnmi => c_csr_csnmi + procedure, pass(a) :: reallocate_nz => c_csr_reallocate_nz + procedure, pass(a) :: csput => c_csr_csput + procedure, pass(a) :: allocate_mnnz => c_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => c_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => c_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => c_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => c_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => c_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => c_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => c_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => c_mv_csr_from_fmt + procedure, pass(a) :: csgetptn => c_csr_csgetptn + procedure, pass(a) :: c_csgetrow => c_csr_csgetrow + procedure, pass(a) :: get_nz_row => c_csr_get_nz_row + procedure, pass(a) :: get_size => c_csr_get_size + procedure, pass(a) :: free => c_csr_free + procedure, pass(a) :: trim => c_csr_trim + procedure, pass(a) :: print => c_csr_print + procedure, pass(a) :: sizeof => c_csr_sizeof + procedure, pass(a) :: reinit => c_csr_reinit + procedure, pass(a) :: c_csr_cp_from + generic, public :: cp_from => c_csr_cp_from + procedure, pass(a) :: c_csr_mv_from + generic, public :: mv_from => c_csr_mv_from + + end type psb_c_csr_sparse_mat + + private :: c_csr_get_nzeros, c_csr_csmm, c_csr_csmv, c_csr_cssm, c_csr_cssv, & + & c_csr_csput, c_csr_reallocate_nz, c_csr_allocate_mnnz, & + & c_csr_free, c_csr_print, c_csr_get_fmt, c_csr_csnmi, get_diag, & + & c_cp_csr_to_coo, c_cp_csr_from_coo, & + & c_mv_csr_to_coo, c_mv_csr_from_coo, & + & c_cp_csr_to_fmt, c_cp_csr_from_fmt, & + & c_mv_csr_to_fmt, c_mv_csr_from_fmt, & + & c_csr_scals, c_csr_scal, c_csr_trim, c_csr_csgetrow, c_csr_get_size, & + & c_csr_sizeof, c_csr_csgetptn, c_csr_get_nz_row, c_csr_reinit +!!$, & +!!$ & c_csr_mv_from, c_csr_mv_from + + + interface + subroutine c_cp_csr_to_fmt_impl(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine c_cp_csr_to_fmt_impl + end interface + + interface + subroutine c_cp_csr_from_fmt_impl(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine c_cp_csr_from_fmt_impl + end interface + + + interface + subroutine c_cp_csr_to_coo_impl(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine c_cp_csr_to_coo_impl + end interface + + interface + subroutine c_cp_csr_from_coo_impl(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine c_cp_csr_from_coo_impl + end interface + + interface + subroutine c_mv_csr_to_fmt_impl(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine c_mv_csr_to_fmt_impl + end interface + + interface + subroutine c_mv_csr_from_fmt_impl(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine c_mv_csr_from_fmt_impl + end interface + + + interface + subroutine c_mv_csr_to_coo_impl(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine c_mv_csr_to_coo_impl + end interface + + interface + subroutine c_mv_csr_from_coo_impl(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine c_mv_csr_from_coo_impl + end interface + + interface + subroutine c_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_const_mod + import psb_c_csr_sparse_mat + 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(:) + end subroutine c_csr_csput_impl + end interface + + interface + subroutine c_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + use psb_const_mod + import psb_c_csr_sparse_mat + implicit none + + 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 + end subroutine c_csr_csgetptn_impl + end interface + + interface + subroutine c_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + use psb_const_mod + import psb_c_csr_sparse_mat + implicit none + + 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 + end subroutine c_csr_csgetrow_impl + end interface + + interface c_csr_cssm_impl + subroutine c_csr_cssv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine c_csr_cssv_impl + subroutine c_csr_cssm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine c_csr_cssm_impl + end interface + + interface c_csr_csmm_impl + subroutine c_csr_csmv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine c_csr_csmv_impl + subroutine c_csr_csmm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine c_csr_csmm_impl + end interface + + interface c_csr_csnmi_impl + function c_csr_csnmi_impl(a) result(res) + use psb_const_mod + import psb_c_csr_sparse_mat + class(psb_c_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function c_csr_csnmi_impl + end interface + + + +contains + + !===================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + !===================================== + + + function c_csr_sizeof(a) result(res) + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + integer(psb_long_int_k_) :: res + res = 8 + res = res + 2*psb_sizeof_sp * size(a%val) + res = res + psb_sizeof_int * size(a%irp) + res = res + psb_sizeof_int * size(a%ja) + + end function c_csr_sizeof + + function c_csr_get_fmt(a) result(res) + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'CSR' + end function c_csr_get_fmt + + function c_csr_get_nzeros(a) result(res) + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + integer :: res + res = a%irp(a%get_nrows()+1)-1 + end function c_csr_get_nzeros + + function c_csr_get_size(a) result(res) + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + integer :: res + + res = -1 + + if (allocated(a%ja)) then + if (res >= 0) then + res = min(res,size(a%ja)) + else + res = size(a%ja) + end if + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function c_csr_get_size + + + + function c_csr_get_nz_row(idx,a) result(res) + use psb_const_mod + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function c_csr_get_nz_row + + + + !===================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !===================================== + + + subroutine c_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_c_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='c_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_reallocate_nz + + subroutine c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_const_mod + use psb_error_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='c_csr_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) + info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + call c_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine c_csr_csput + + subroutine c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + call c_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_csgetptn + + + subroutine c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + call c_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_csgetrow + + + subroutine c_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_csgetblk + + + subroutine c_csr_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_csclip + + + subroutine c_csr_free(a) + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0) + call a%set_ncols(0) + + return + + end subroutine c_csr_free + + subroutine c_csr_reinit(a,clear) + use psb_error_mod + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = czero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_reinit + + + subroutine c_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + m = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_trim + + + subroutine c_cp_csr_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_cp_csr_to_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_cp_csr_to_coo + + subroutine c_cp_csr_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_cp_csr_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_cp_csr_from_coo + + + subroutine c_cp_csr_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_cp_csr_to_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_cp_csr_to_fmt + + subroutine c_cp_csr_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_cp_csr_from_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_cp_csr_from_fmt + + + subroutine c_mv_csr_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_mv_csr_to_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_mv_csr_to_coo + + subroutine c_mv_csr_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_mv_csr_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_mv_csr_from_coo + + + subroutine c_mv_csr_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_mv_csr_to_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_mv_csr_to_fmt + + subroutine c_mv_csr_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call c_mv_csr_from_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_mv_csr_from_fmt + + + subroutine c_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_c_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nc_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nc_ = nz + else + nc_ = max(7*m,7*n,1) + end if + if (nc_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == 0) call psb_realloc(nc_,a%ja,info) + if (info == 0) call psb_realloc(nc_,a%val,info) + if (info == 0) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_allocate_mnnz + + + subroutine c_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + implicit none + + integer, intent(in) :: iout + class(psb_c_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='c_csr_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + + end subroutine c_csr_print + + + subroutine c_csr_cp_from(a,b) + use psb_error_mod + implicit none + + class(psb_c_csr_sparse_mat), intent(out) :: a + type(psb_c_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_csr_cp_from + + subroutine c_csr_mv_from(a,b) + use psb_error_mod + implicit none + + class(psb_c_csr_sparse_mat), intent(out) :: a + type(psb_c_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine c_csr_mv_from + + + + !===================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !===================================== + + + subroutine c_csr_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_spk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='c_csr_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call c_csr_csmm_impl(alpha,a,x,beta,y,info,trans) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_csmv + + subroutine c_csr_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='c_csr_csmm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + + + call c_csr_csmm_impl(alpha,a,x,beta,y,info,trans) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_csmm + + + subroutine c_csr_cssv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='c_csr_cssv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call c_csr_cssm_impl(alpha,a,x,beta,y,info,trans) + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + end subroutine c_csr_cssv + + + + subroutine c_csr_cssm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='c_csr_csmm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call c_csr_cssm_impl(alpha,a,x,beta,y,info,trans) + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_cssm + + function c_csr_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + + res = c_csr_csnmi_impl(a) + + return + + end function c_csr_csnmi + + subroutine c_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = czero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_get_diag + + + subroutine c_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_scal + + + subroutine c_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csr_scals + + + +end module psb_c_csr_mat_mod diff --git a/base/modules/psb_c_mat_mod.f03 b/base/modules/psb_c_mat_mod.f03 new file mode 100644 index 00000000..f3afd33c --- /dev/null +++ b/base/modules/psb_c_mat_mod.f03 @@ -0,0 +1,1924 @@ +module psb_c_mat_mod + + use psb_c_base_mat_mod + use psb_c_csr_mat_mod + + type :: psb_c_sparse_mat + + class(psb_c_base_sparse_mat), allocatable :: a + + contains + ! Setters + procedure, pass(a) :: set_nrows + procedure, pass(a) :: set_ncols + procedure, pass(a) :: set_dupl + procedure, pass(a) :: set_state + procedure, pass(a) :: set_null + procedure, pass(a) :: set_bld + procedure, pass(a) :: set_upd + procedure, pass(a) :: set_asb + procedure, pass(a) :: set_sorted + procedure, pass(a) :: set_upper + procedure, pass(a) :: set_lower + procedure, pass(a) :: set_triangle + procedure, pass(a) :: set_unit + ! Getters + procedure, pass(a) :: get_nrows + procedure, pass(a) :: get_ncols + procedure, pass(a) :: get_nzeros + procedure, pass(a) :: get_nz_row + procedure, pass(a) :: get_size + procedure, pass(a) :: get_state + procedure, pass(a) :: get_dupl + procedure, pass(a) :: is_null + procedure, pass(a) :: is_bld + procedure, pass(a) :: is_upd + procedure, pass(a) :: is_asb + procedure, pass(a) :: is_sorted + procedure, pass(a) :: is_upper + procedure, pass(a) :: is_lower + procedure, pass(a) :: is_triangle + procedure, pass(a) :: is_unit + procedure, pass(a) :: get_fmt => sparse_get_fmt + procedure, pass(a) :: sizeof => c_sizeof + + + ! Memory/data management + procedure, pass(a) :: csall + procedure, pass(a) :: free + procedure, pass(a) :: trim + procedure, pass(a) :: csput + procedure, pass(a) :: c_csgetptn + procedure, pass(a) :: c_csgetrow + procedure, pass(a) :: c_csgetblk + generic, public :: csget => c_csgetptn, c_csgetrow, c_csgetblk + procedure, pass(a) :: csclip + procedure, pass(a) :: reall => reallocate_nz + procedure, pass(a) :: get_neigh + procedure, pass(a) :: c_cscnv + procedure, pass(a) :: c_cscnv_ip + generic, public :: cscnv => c_cscnv, c_cscnv_ip + procedure, pass(a) :: reinit + procedure, pass(a) :: print => sparse_print + procedure, pass(a) :: c_mv_from + generic, public :: mv_from => c_mv_from + procedure, pass(a) :: c_cp_from + generic, public :: cp_from => c_cp_from + + + ! Computational routines + procedure, pass(a) :: get_diag + procedure, pass(a) :: csnmi + procedure, pass(a) :: c_csmv + procedure, pass(a) :: c_csmm + generic, public :: csmm => c_csmm, c_csmv + procedure, pass(a) :: c_scals + procedure, pass(a) :: c_scal + generic, public :: scal => c_scals, c_scal + procedure, pass(a) :: c_cssv + procedure, pass(a) :: c_cssm + generic, public :: cssm => c_cssm, c_cssv + + end type psb_c_sparse_mat + + private :: get_nrows, get_ncols, get_nzeros, get_size, & + & get_state, get_dupl, is_null, is_bld, is_upd, & + & is_asb, is_sorted, is_upper, is_lower, is_triangle, & + & is_unit, get_neigh, csall, csput, c_csgetrow,& + & c_csgetblk, csclip, c_cscnv, c_cscnv_ip, & + & reallocate_nz, free, trim, & + & sparse_print, reinit, & + & set_nrows, set_ncols, set_dupl, & + & set_state, set_null, set_bld, & + & set_upd, set_asb, set_sorted, & + & set_upper, set_lower, set_triangle, & + & set_unit, get_diag, get_nz_row, c_csgetptn, & + & c_mv_from, c_cp_from + + interface psb_sizeof + module procedure c_sizeof + end interface + + interface psb_move_alloc + module procedure c_sparse_mat_move + end interface + + interface psb_clone + module procedure c_sparse_mat_clone + end interface + + interface psb_csmm + module procedure c_csmm, c_csmv + end interface + + interface psb_cssm + module procedure c_cssm, c_cssv + end interface + + interface psb_csnmi + module procedure csnmi + end interface + + interface psb_scal + module procedure c_scals, c_scal + end interface + +contains + + + !===================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + !===================================== + + + function c_sizeof(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + integer(psb_long_int_k_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function c_sizeof + + + + function sparse_get_fmt(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function sparse_get_fmt + + + + function get_dupl(a) result(res) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + integer :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function get_dupl + + + function get_state(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + integer :: res + + if (allocated(a%a)) then + res = a%a%get_state() + else + res = psb_spmat_null_ + end if + end function get_state + + function get_nrows(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + integer :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function get_nrows + + function get_ncols(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + integer :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function get_ncols + + function is_triangle(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function is_triangle + + function is_unit(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function is_unit + + function is_upper(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function is_upper + + function is_lower(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function is_lower + + function is_null(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function is_null + + function is_bld(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function is_bld + + function is_upd(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function is_upd + + function is_asb(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function is_asb + + function is_sorted(a) result(res) + implicit none + class(psb_c_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function is_sorted + + + + function get_nzeros(a) result(res) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%get_nzeros() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end function get_nzeros + + function get_size(a) result(res) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act, info + character(len=20) :: name='get_size' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%get_size() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end function get_size + + + function get_nz_row(idx,a) result(res) + use psb_error_mod + implicit none + integer, intent(in) :: idx + class(psb_c_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function get_nz_row + + + + !===================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + !===================================== + + + subroutine set_nrows(m,a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_nrows + + subroutine set_ncols(n,a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_ncols + + + subroutine set_state(n,a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_state + + + subroutine set_dupl(n,a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_dupl + + subroutine set_null(a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_null + + subroutine set_bld(a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_bld + + subroutine set_upd(a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_upd + + subroutine set_asb(a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_asb + + subroutine set_sorted(a,val) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_sorted + + subroutine set_triangle(a,val) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_triangle + + subroutine set_unit(a,val) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_unit + + subroutine set_lower(a,val) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_lower + + subroutine set_upper(a,val) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_upper + + + !===================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !===================================== + + + subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 0 + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine sparse_print + + + + subroutine get_neigh(a,idx,neigh,n,info,lev) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine get_neigh + + + subroutine csall(nr,nc,a,info,nz) + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + allocate(psb_c_coo_sparse_mat :: a%a, stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine csall + + subroutine reallocate_nz(nz,a) + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine reallocate_nz + + subroutine free(a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%free() + deallocate(a%a) + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine free + + subroutine trim(a) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine trim + + + subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.a%is_bld()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine csput + + subroutine c_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine c_csgetptn + + subroutine c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine c_csgetrow + + + + subroutine c_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + + if (info == 0) call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine c_csgetblk + + + + subroutine csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + implicit none + + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat), allocatable :: acoo + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine csclip + + + + subroutine c_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + + + class(psb_c_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_c_coo_sparse_mat :: altmp, stat=info) + case default + info = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine c_cscnv + + + subroutine c_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + implicit none + + class(psb_c_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + + + class(psb_c_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_c_coo_sparse_mat :: altmp, stat=info) + case default + info = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine c_cscnv_ip + + subroutine c_mv_from(a,b) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer :: info + + allocate(a%a,source=b, stat=info) + call a%a%mv_from_fmt(b,info) + + return + end subroutine c_mv_from + + subroutine c_cp_from(a,b) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_sparse_mat), intent(out) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(a%a,source=b,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call a%a%cp_from_fmt(b, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end subroutine c_cp_from + + subroutine c_sparse_mat_move(a,b,info) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = 0 + call move_alloc(a%a,b%a) + + return + end subroutine c_sparse_mat_move + + subroutine c_sparse_mat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + class(psb_c_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(b%a,source=a%a,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call b%a%cp_from_fmt(a%a, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine c_sparse_mat_clone + + + subroutine reinit(a,clear) + use psb_error_mod + implicit none + + class(psb_c_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine reinit + + + !===================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !===================================== + + + subroutine c_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csmm + + subroutine c_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_csmv + + subroutine c_cssm(alpha,a,x,beta,y,info,trans,side,d) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, side + complex(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,side,d) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_cssm + + subroutine c_cssv(alpha,a,x,beta,y,info,trans,side,d) + use psb_error_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, side + complex(psb_spk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,side,d) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_cssv + + + function csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end function csnmi + + + + subroutine get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine get_diag + + subroutine c_scal(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_scal + + subroutine c_scals(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine c_scals + + +end module psb_c_mat_mod diff --git a/base/modules/psb_mat_mod.f03 b/base/modules/psb_mat_mod.f03 index 30fa1ebd..756cee10 100644 --- a/base/modules/psb_mat_mod.f03 +++ b/base/modules/psb_mat_mod.f03 @@ -1,4 +1,6 @@ module psb_mat_mod use psb_s_mat_mod use psb_d_mat_mod + use psb_c_mat_mod + use psb_z_mat_mod end module psb_mat_mod diff --git a/base/modules/psb_z_base_mat_mod.f03 b/base/modules/psb_z_base_mat_mod.f03 new file mode 100644 index 00000000..37246126 --- /dev/null +++ b/base/modules/psb_z_base_mat_mod.f03 @@ -0,0 +1,2595 @@ +module psb_z_base_mat_mod + + use psb_base_mat_mod + + type, extends(psb_base_sparse_mat) :: psb_z_base_sparse_mat + contains + procedure, pass(a) :: z_base_csmv + procedure, pass(a) :: z_base_csmm + generic, public :: csmm => z_base_csmm, z_base_csmv + procedure, pass(a) :: z_base_cssv + procedure, pass(a) :: z_base_cssm + generic, public :: base_cssm => z_base_cssm, z_base_cssv + procedure, pass(a) :: z_cssv + procedure, pass(a) :: z_cssm + generic, public :: cssm => z_cssm, z_cssv + procedure, pass(a) :: z_scals + procedure, pass(a) :: z_scal + generic, public :: scal => z_scals, z_scal + procedure, pass(a) :: csnmi + procedure, pass(a) :: get_diag + procedure, pass(a) :: csput + + procedure, pass(a) :: z_csgetrow + procedure, pass(a) :: z_csgetblk + generic, public :: csget => z_csgetrow, z_csgetblk + procedure, pass(a) :: csclip + procedure, pass(a) :: cp_to_coo + procedure, pass(a) :: cp_from_coo + procedure, pass(a) :: cp_to_fmt + procedure, pass(a) :: cp_from_fmt + procedure, pass(a) :: mv_to_coo + procedure, pass(a) :: mv_from_coo + procedure, pass(a) :: mv_to_fmt + procedure, pass(a) :: mv_from_fmt + procedure, pass(a) :: z_base_cp_from + generic, public :: cp_from => z_base_cp_from + procedure, pass(a) :: z_base_mv_from + generic, public :: mv_from => z_base_mv_from + end type psb_z_base_sparse_mat + + private :: z_base_csmv, z_base_csmm, z_base_cssv, z_base_cssm,& + & z_scals, z_scal, csnmi, csput, z_csgetrow, z_csgetblk, & + & cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, & + & mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, & + & get_diag, csclip, z_cssv, z_cssm, base_cp_from, base_mv_from + + type, extends(psb_z_base_sparse_mat) :: psb_z_coo_sparse_mat + + integer :: nnz + integer, allocatable :: ia(:), ja(:) + complex(psb_dpk_), allocatable :: val(:) + + contains + + procedure, pass(a) :: get_size => z_coo_get_size + procedure, pass(a) :: get_nzeros => z_coo_get_nzeros + procedure, pass(a) :: set_nzeros => z_coo_set_nzeros + procedure, pass(a) :: z_base_csmm => z_coo_csmm + procedure, pass(a) :: z_base_csmv => z_coo_csmv + procedure, pass(a) :: z_base_cssm => z_coo_cssm + procedure, pass(a) :: z_base_cssv => z_coo_cssv + procedure, pass(a) :: z_scals => z_coo_scals + procedure, pass(a) :: z_scal => z_coo_scal + procedure, pass(a) :: csnmi => z_coo_csnmi + procedure, pass(a) :: csput => z_coo_csput + procedure, pass(a) :: get_diag => z_coo_get_diag + procedure, pass(a) :: reallocate_nz => z_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => z_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => z_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => z_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => z_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => z_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => z_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => z_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => z_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => z_mv_coo_from_fmt + procedure, pass(a) :: fix => z_fix_coo + procedure, pass(a) :: free => z_coo_free + procedure, pass(a) :: trim => z_coo_trim + procedure, pass(a) :: z_csgetrow => z_coo_csgetrow + procedure, pass(a) :: csgetptn => z_coo_csgetptn + procedure, pass(a) :: print => z_coo_print + procedure, pass(a) :: get_fmt => z_coo_get_fmt + procedure, pass(a) :: get_nz_row => z_coo_get_nz_row + procedure, pass(a) :: sizeof => z_coo_sizeof + procedure, pass(a) :: reinit => z_coo_reinit + procedure, pass(a) :: z_coo_cp_from + generic, public :: cp_from => z_coo_cp_from + procedure, pass(a) :: z_coo_mv_from + generic, public :: mv_from => z_coo_mv_from + + end type psb_z_coo_sparse_mat + + private :: z_coo_get_nzeros, z_coo_set_nzeros, z_coo_get_diag, & + & z_coo_csmm, z_coo_csmv, z_coo_cssm, z_coo_cssv, z_coo_csnmi, & + & z_coo_csput, z_coo_reallocate_nz, z_coo_allocate_mnnz, & + & z_fix_coo, z_coo_free, z_coo_print, z_coo_get_fmt, & + & z_cp_coo_to_coo, z_cp_coo_from_coo, & + & z_cp_coo_to_fmt, z_cp_coo_from_fmt, & + & z_coo_scals, z_coo_scal, z_coo_csgetrow, z_coo_sizeof, & + & z_coo_csgetptn, z_coo_get_nz_row, z_coo_reinit,& + & z_coo_cp_from, z_coo_mv_from + + + interface + subroutine z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + integer, intent(in) :: nzin,dupl + integer, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), intent(inout) :: val(:) + integer, intent(out) :: nzout, info + integer, intent(in), optional :: idir + end subroutine z_fix_coo_inner + end interface + + interface + subroutine z_fix_coo_impl(a,info,idir) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + end subroutine z_fix_coo_impl + end interface + + interface + subroutine z_cp_coo_to_coo_impl(a,b,info) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine z_cp_coo_to_coo_impl + end interface + + interface + subroutine z_cp_coo_from_coo_impl(a,b,info) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(out) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine z_cp_coo_from_coo_impl + end interface + + interface + subroutine z_cp_coo_to_fmt_impl(a,b,info) + use psb_const_mod + import psb_z_coo_sparse_mat, psb_z_base_sparse_mat + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine z_cp_coo_to_fmt_impl + end interface + + interface + subroutine z_cp_coo_from_fmt_impl(a,b,info) + use psb_const_mod + import psb_z_coo_sparse_mat, psb_z_base_sparse_mat + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine z_cp_coo_from_fmt_impl + end interface + + interface + subroutine z_mv_coo_to_coo_impl(a,b,info) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine z_mv_coo_to_coo_impl + end interface + + interface + subroutine z_mv_coo_from_coo_impl(a,b,info) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine z_mv_coo_from_coo_impl + end interface + + interface + subroutine z_mv_coo_to_fmt_impl(a,b,info) + use psb_const_mod + import psb_z_coo_sparse_mat, psb_z_base_sparse_mat + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine z_mv_coo_to_fmt_impl + end interface + + interface + subroutine z_mv_coo_from_fmt_impl(a,b,info) + use psb_const_mod + import psb_z_coo_sparse_mat, psb_z_base_sparse_mat + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine z_mv_coo_from_fmt_impl + end interface + + + interface + subroutine z_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + end subroutine z_coo_csput_impl + end interface + + interface + subroutine z_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + use psb_const_mod + import psb_z_coo_sparse_mat + implicit none + 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 + end subroutine z_coo_csgetptn_impl + end interface + + interface + subroutine z_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + use psb_const_mod + import psb_z_coo_sparse_mat + implicit none + + 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 + end subroutine z_coo_csgetrow_impl + end interface + + interface z_coo_cssm_impl + subroutine z_coo_cssv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine z_coo_cssv_impl + subroutine z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine z_coo_cssm_impl + end interface + + interface z_coo_csmm_impl + subroutine z_coo_csmv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine z_coo_csmv_impl + subroutine z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine z_coo_csmm_impl + end interface + + + interface z_coo_csnmi_impl + function z_coo_csnmi_impl(a) result(res) + use psb_const_mod + import psb_z_coo_sparse_mat + class(psb_z_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function z_coo_csnmi_impl + end interface + + +contains + + + !==================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !==================================== + + subroutine cp_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine cp_to_coo + + subroutine cp_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine cp_from_coo + + + subroutine cp_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine cp_to_fmt + + subroutine cp_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine cp_from_fmt + + + subroutine mv_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine mv_to_coo + + subroutine mv_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine mv_from_coo + + + subroutine mv_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine mv_to_fmt + + subroutine mv_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine mv_from_fmt + + subroutine z_base_mv_from(a,b) + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(out) :: a + type(psb_z_base_sparse_mat), intent(inout) :: b + + + ! No new things here, very easy + call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) + + return + + end subroutine z_base_mv_from + + subroutine z_base_cp_from(a,b) + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(out) :: a + type(psb_z_base_sparse_mat), intent(in) :: b + + ! No new things here, very easy + call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) + + return + + end subroutine z_base_cp_from + + + + subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine csput + + subroutine z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_base_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_csgetrow + + + + subroutine z_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csgetblk + + + subroutine csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine csclip + + + + !==================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !==================================== + + subroutine z_base_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_csmm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_base_csmm + + subroutine z_base_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_csmv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + + end subroutine z_base_csmv + + subroutine z_base_cssm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_cssm' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_base_cssm + + subroutine z_base_cssv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + Integer :: err_act + character(len=20) :: name='z_base_cssv' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_base_cssv + + subroutine z_cssm(alpha,a,x,beta,y,info,trans,side,d) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, side + complex(psb_dpk_), intent(in), optional :: d(:) + + complex(psb_dpk_), allocatable :: tmp(:,:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: side_ + character(len=20) :: name='z_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = min(size(x,2), size(y,2)) + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(side)) then + side_ = side + else + side_ = 'L' + end if + + if (psb_toupper(side_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0) then + do i=1, nac + tmp(i,1:nc) = d(i)*x(i,1:nc) + end do + end if + if (info == 0)& + & call a%base_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(side_) == 'L') then + + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar,nc),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%base_cssm(zone,x,zzero,tmp,info,trans) + + if (info == 0)then + do i=1, nar + tmp(i,1:nc) = d(i)*tmp(i,1:nc) + end do + end if + if (info == 0)& + & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=side_) + goto 9999 + end if + else + ! Side is ignored in this case + call a%base_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='base_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + end subroutine z_cssm + + subroutine z_cssv(alpha,a,x,beta,y,info,trans,side,d) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, side + complex(psb_dpk_), intent(in), optional :: d(:) + + complex(psb_dpk_), allocatable :: tmp(:) + Integer :: err_act, nar,nac,nc, i + character(len=1) :: side_ + character(len=20) :: name='z_cssm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + nc = 1 + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(d)) then + if (present(side)) then + side_ = side + else + side_ = 'L' + end if + + if (psb_toupper(side_) == 'R') then + if (size(d,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nac,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nac),stat=info) + if (info /= 0) info = 4000 + if (info == 0) tmp(1:nac) = d(1:nac)*x(1:nac) + if (info == 0)& + & call a%base_cssm(alpha,tmp,beta,y,info,trans) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else if (psb_toupper(side_) == 'L') then + if (size(d,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/9,nar,0,0,0/)) + goto 9999 + end if + + allocate(tmp(nar),stat=info) + if (info /= 0) info = 4000 + if (info == 0)& + & call a%base_cssm(zone,x,zzero,tmp,info,trans) + + if (info == 0) tmp(1:nar) = d(1:nar)*tmp(1:nar) + if (info == 0)& + & call psb_geaxpby(nar,alpha,tmp,beta,y,info) + + if (info == 0) then + deallocate(tmp,stat=info) + if (info /= 0) info = 4000 + end if + + else + info = 31 + call psb_errpush(info,name,i_err=(/8,0,0,0,0/),a_err=side_) + goto 9999 + end if + else + ! Side is ignored in this case + call a%base_cssm(alpha,x,beta,y,info,trans) + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name, a_err='base_cssm') + goto 9999 + end if + + + return + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + end subroutine z_cssv + + + subroutine z_scals(d,a,info) + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='z_scals' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_scals + + + subroutine z_scal(d,a,info) + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='z_scal' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_scal + + + function csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + res = -done + + return + + end function csnmi + + subroutine get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + + end subroutine get_diag + + + + + !==================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + !==================================== + + + + function z_coo_sizeof(a) result(res) + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + integer(psb_long_int_k_) :: res + res = 8 + 1 + res = res + 2*psb_sizeof_dp * size(a%val) + res = res + psb_sizeof_int * size(a%ia) + res = res + psb_sizeof_int * size(a%ja) + + end function z_coo_sizeof + + + function z_coo_get_fmt(a) result(res) + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'COO' + end function z_coo_get_fmt + + + function z_coo_get_size(a) result(res) + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + integer :: res + res = -1 + + if (allocated(a%ia)) res = size(a%ia) + if (allocated(a%ja)) then + if (res >= 0) then + res = min(res,size(a%ja)) + else + res = size(a%ja) + end if + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + end function z_coo_get_size + + + function z_coo_get_nzeros(a) result(res) + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + integer :: res + res = a%nnz + end function z_coo_get_nzeros + + + function z_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + integer :: nzin_, nza,ip,jp,i,k + + res = 0 + nza = a%get_nzeros() + if (a%is_sorted()) then + ! In this case we can do a binary search. + ip = psb_ibsrch(idx,nza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + + end function z_coo_get_nz_row + + !==================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + !==================================== + + subroutine z_coo_set_nzeros(nz,a) + implicit none + integer, intent(in) :: nz + class(psb_z_coo_sparse_mat), intent(inout) :: a + + a%nnz = nz + + end subroutine z_coo_set_nzeros + + !==================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !==================================== + + + subroutine z_fix_coo(a,info,idir) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer, intent(in), optional :: idir + Integer :: err_act + character(len=20) :: name='fix_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_fix_coo_impl(a,info,idir) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + + end subroutine z_fix_coo + + + subroutine z_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_cp_coo_to_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_cp_coo_to_coo + + subroutine z_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(out) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_cp_coo_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_cp_coo_from_coo + + + subroutine z_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_cp_coo_to_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_cp_coo_to_fmt + + subroutine z_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_cp_coo_from_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_cp_coo_from_fmt + + + + subroutine z_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_mv_coo_to_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_mv_coo_to_coo + + subroutine z_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_mv_coo_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_mv_coo_from_coo + + + + subroutine z_coo_cp_from(a,b) + use psb_error_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(out) :: a + type(psb_z_coo_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_cp_coo_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_coo_cp_from + + subroutine z_coo_mv_from(a,b) + use psb_error_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(out) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_mv_coo_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_coo_mv_from + + + subroutine z_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_mv_coo_to_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_mv_coo_to_fmt + + subroutine z_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_mv_coo_from_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_mv_coo_from_fmt + + + + subroutine z_coo_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_z_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='z_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ia,a%ja,a%val,info) + + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_reallocate_nz + + + subroutine z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='z_coo_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) + info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + nza = a%get_nzeros() + call z_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_csput + + + subroutine z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + call z_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_csgetrow + + + subroutine z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + call z_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_csgetptn + + + subroutine z_coo_free(a) + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0) + call a%set_ncols(0) + + return + + end subroutine z_coo_free + + subroutine z_coo_reinit(a,clear) + use psb_error_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_reinit + + + subroutine z_coo_trim(a) + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + nz = a%get_nzeros() + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_trim + + subroutine z_coo_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_z_coo_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + if (info == 0) call psb_realloc(nz_,a%ia,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(0) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + end if + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_allocate_mnnz + + + subroutine z_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + implicit none + + integer, intent(in) :: iout + class(psb_z_coo_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='z_coo_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + + end subroutine z_coo_print + + + + + !==================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !==================================== + + subroutine z_coo_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nac, nar + complex(psb_dpk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='z_coo_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + nar = a%get_nrows() + nac = a%get_ncols() + if (size(x) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + + call z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_csmv + + subroutine z_coo_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac + complex(psb_dpk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='z_coo_csmm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + nar = a%get_nrows() + nac = a%get_ncols() + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + call z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_csmm + + + subroutine z_coo_cssv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nar, nac + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='z_coo_cssv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + end subroutine z_coo_cssv + + + + subroutine z_coo_cssm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc, nar, nac + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='z_coo_csmm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + nar = a%get_nrows() + nac = a%get_ncols() + if (size(x,1) < nac) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nac,0,0,0/)) + goto 9999 + end if + if (size(y,1) < nar) then + info = 36 + call psb_errpush(info,name,i_err=(/3,nar,0,0,0/)) + goto 9999 + end if + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_cssm + + function z_coo_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + + res = z_coo_csnmi_impl(a) + + return + + end function z_coo_csnmi + + subroutine z_coo_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + d(:) = zzero + + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_get_diag + + subroutine z_coo_scal(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_scal + + subroutine z_coo_scals(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_coo_scals + + +end module psb_z_base_mat_mod + + + diff --git a/base/modules/psb_z_csr_mat_mod.f03 b/base/modules/psb_z_csr_mat_mod.f03 new file mode 100644 index 00000000..395217c5 --- /dev/null +++ b/base/modules/psb_z_csr_mat_mod.f03 @@ -0,0 +1,1604 @@ +module psb_z_csr_mat_mod + + use psb_z_base_mat_mod + + type, extends(psb_z_base_sparse_mat) :: psb_z_csr_sparse_mat + + integer, allocatable :: irp(:), ja(:) + complex(psb_dpk_), allocatable :: val(:) + + contains + procedure, pass(a) :: get_nzeros => z_csr_get_nzeros + procedure, pass(a) :: get_fmt => z_csr_get_fmt + procedure, pass(a) :: get_diag => z_csr_get_diag + procedure, pass(a) :: z_base_csmm => z_csr_csmm + procedure, pass(a) :: z_base_csmv => z_csr_csmv + procedure, pass(a) :: z_base_cssm => z_csr_cssm + procedure, pass(a) :: z_base_cssv => z_csr_cssv + procedure, pass(a) :: z_scals => z_csr_scals + procedure, pass(a) :: z_scal => z_csr_scal + procedure, pass(a) :: csnmi => z_csr_csnmi + procedure, pass(a) :: reallocate_nz => z_csr_reallocate_nz + procedure, pass(a) :: csput => z_csr_csput + procedure, pass(a) :: allocate_mnnz => z_csr_allocate_mnnz + procedure, pass(a) :: cp_to_coo => z_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => z_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => z_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => z_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => z_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => z_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => z_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => z_mv_csr_from_fmt + procedure, pass(a) :: csgetptn => z_csr_csgetptn + procedure, pass(a) :: z_csgetrow => z_csr_csgetrow + procedure, pass(a) :: get_nz_row => z_csr_get_nz_row + procedure, pass(a) :: get_size => z_csr_get_size + procedure, pass(a) :: free => z_csr_free + procedure, pass(a) :: trim => z_csr_trim + procedure, pass(a) :: print => z_csr_print + procedure, pass(a) :: sizeof => z_csr_sizeof + procedure, pass(a) :: reinit => z_csr_reinit + procedure, pass(a) :: z_csr_cp_from + generic, public :: cp_from => z_csr_cp_from + procedure, pass(a) :: z_csr_mv_from + generic, public :: mv_from => z_csr_mv_from + + end type psb_z_csr_sparse_mat + + private :: z_csr_get_nzeros, z_csr_csmm, z_csr_csmv, z_csr_cssm, z_csr_cssv, & + & z_csr_csput, z_csr_reallocate_nz, z_csr_allocate_mnnz, & + & z_csr_free, z_csr_print, z_csr_get_fmt, z_csr_csnmi, get_diag, & + & z_cp_csr_to_coo, z_cp_csr_from_coo, & + & z_mv_csr_to_coo, z_mv_csr_from_coo, & + & z_cp_csr_to_fmt, z_cp_csr_from_fmt, & + & z_mv_csr_to_fmt, z_mv_csr_from_fmt, & + & z_csr_scals, z_csr_scal, z_csr_trim, z_csr_csgetrow, z_csr_get_size, & + & z_csr_sizeof, z_csr_csgetptn, z_csr_get_nz_row, z_csr_reinit +!!$, & +!!$ & z_csr_mv_from, z_csr_mv_from + + + interface + subroutine z_cp_csr_to_fmt_impl(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine z_cp_csr_to_fmt_impl + end interface + + interface + subroutine z_cp_csr_from_fmt_impl(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine z_cp_csr_from_fmt_impl + end interface + + + interface + subroutine z_cp_csr_to_coo_impl(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine z_cp_csr_to_coo_impl + end interface + + interface + subroutine z_cp_csr_from_coo_impl(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + end subroutine z_cp_csr_from_coo_impl + end interface + + interface + subroutine z_mv_csr_to_fmt_impl(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine z_mv_csr_to_fmt_impl + end interface + + interface + subroutine z_mv_csr_from_fmt_impl(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine z_mv_csr_from_fmt_impl + end interface + + + interface + subroutine z_mv_csr_to_coo_impl(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + end subroutine z_mv_csr_to_coo_impl + end interface + + interface + subroutine z_mv_csr_from_coo_impl(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + end subroutine z_mv_csr_from_coo_impl + end interface + + interface + subroutine z_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_const_mod + import psb_z_csr_sparse_mat + 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(:) + end subroutine z_csr_csput_impl + end interface + + interface + subroutine z_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + use psb_const_mod + import psb_z_csr_sparse_mat + implicit none + + 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 + end subroutine z_csr_csgetptn_impl + end interface + + interface + subroutine z_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + use psb_const_mod + import psb_z_csr_sparse_mat + implicit none + + 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 + end subroutine z_csr_csgetrow_impl + end interface + + interface z_csr_cssm_impl + subroutine z_csr_cssv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine z_csr_cssv_impl + subroutine z_csr_cssm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine z_csr_cssm_impl + end interface + + interface z_csr_csmm_impl + subroutine z_csr_csmv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine z_csr_csmv_impl + subroutine z_csr_csmm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + end subroutine z_csr_csmm_impl + end interface + + interface z_csr_csnmi_impl + function z_csr_csnmi_impl(a) result(res) + use psb_const_mod + import psb_z_csr_sparse_mat + class(psb_z_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function z_csr_csnmi_impl + end interface + + + +contains + + !===================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + !===================================== + + + function z_csr_sizeof(a) result(res) + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + integer(psb_long_int_k_) :: res + res = 8 + res = res + 2*psb_sizeof_dp * size(a%val) + res = res + psb_sizeof_int * size(a%irp) + res = res + psb_sizeof_int * size(a%ja) + + end function z_csr_sizeof + + function z_csr_get_fmt(a) result(res) + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'CSR' + end function z_csr_get_fmt + + function z_csr_get_nzeros(a) result(res) + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + integer :: res + res = a%irp(a%get_nrows()+1)-1 + end function z_csr_get_nzeros + + function z_csr_get_size(a) result(res) + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + integer :: res + + res = -1 + + if (allocated(a%ja)) then + if (res >= 0) then + res = min(res,size(a%ja)) + else + res = size(a%ja) + end if + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function z_csr_get_size + + + + function z_csr_get_nz_row(idx,a) result(res) + use psb_const_mod + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function z_csr_get_nz_row + + + + !===================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !===================================== + + + subroutine z_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: nz + class(psb_z_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='z_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_reallocate_nz + + subroutine z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_const_mod + use psb_error_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + + Integer :: err_act + character(len=20) :: name='z_csr_csput' + logical, parameter :: debug=.false. + integer :: nza, i,j,k, nzl, isza, int_err(5) + + call psb_erractionsave(err_act) + info = 0 + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + call z_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine z_csr_csput + + subroutine z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + call z_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_csgetptn + + + subroutine z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + call z_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_csgetrow + + + subroutine z_csr_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + Integer :: err_act, nzin, nzout + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_csgetblk + + + subroutine z_csr_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + + if (info /= 0) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_csclip + + + subroutine z_csr_free(a) + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0) + call a%set_ncols(0) + + return + + end subroutine z_csr_free + + subroutine z_csr_reinit(a,clear) + use psb_error_mod + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + Integer :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + else + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_reinit + + + subroutine z_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz, m + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + m = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_trim + + + subroutine z_cp_csr_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_cp_csr_to_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_cp_csr_to_coo + + subroutine z_cp_csr_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_cp_csr_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_cp_csr_from_coo + + + subroutine z_cp_csr_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_cp_csr_to_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_cp_csr_to_fmt + + subroutine z_cp_csr_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_cp_csr_from_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_cp_csr_from_fmt + + + subroutine z_mv_csr_to_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_mv_csr_to_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_mv_csr_to_coo + + subroutine z_mv_csr_from_coo(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_mv_csr_from_coo_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_mv_csr_from_coo + + + subroutine z_mv_csr_to_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_mv_csr_to_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_mv_csr_to_fmt + + subroutine z_mv_csr_from_fmt(a,b,info) + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call z_mv_csr_from_fmt_impl(a,b,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_mv_csr_from_fmt + + + subroutine z_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + implicit none + integer, intent(in) :: m,n + class(psb_z_csr_sparse_mat), intent(inout) :: a + integer, intent(in), optional :: nz + Integer :: err_act, info, nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (present(nz)) then + nz_ = nz + else + nz_ = max(7*m,7*n,1) + end if + if (nz_ < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == 0) call psb_realloc(nz_,a%ja,info) + if (info == 0) call psb_realloc(nz_,a%val,info) + if (info == 0) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_allocate_mnnz + + + subroutine z_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_string_mod + implicit none + + integer, intent(in) :: iout + class(psb_z_csr_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act + character(len=20) :: name='z_csr_print' + logical, parameter :: debug=.false. + + character(len=80) :: frmtv + integer :: irs,ics,i,j, nmx, ni, nr, nc, nz + + if (present(eirs)) then + irs = eirs + else + irs = 0 + endif + if (present(eics)) then + ics = eics + else + ics = 0 + endif + + if (present(head)) then + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + endif + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + ni = floor(log10(1.0*nmx)) + 1 + + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + + end subroutine z_csr_print + + + subroutine z_csr_cp_from(a,b) + use psb_error_mod + implicit none + + class(psb_z_csr_sparse_mat), intent(out) :: a + type(psb_z_csr_sparse_mat), intent(in) :: b + + + Integer :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + info = 0 + + call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + a%irp = b%irp + a%ja = b%ja + a%val = b%val + + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_csr_cp_from + + subroutine z_csr_mv_from(a,b) + use psb_error_mod + implicit none + + class(psb_z_csr_sparse_mat), intent(out) :: a + type(psb_z_csr_sparse_mat), intent(inout) :: b + + + Integer :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + + end subroutine z_csr_mv_from + + + + !===================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !===================================== + + + subroutine z_csr_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_dpk_) :: acc + logical :: tra + Integer :: err_act + character(len=20) :: name='z_csr_csmv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call z_csr_csmm_impl(alpha,a,x,beta,y,info,trans) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_csmv + + subroutine z_csr_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_), allocatable :: acc(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='z_csr_csmm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + + + call z_csr_csmm_impl(alpha,a,x,beta,y,info,trans) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_csmm + + + subroutine z_csr_cssv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:) + logical :: tra + Integer :: err_act + character(len=20) :: name='z_csr_cssv' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call z_csr_cssm_impl(alpha,a,x,beta,y,info,trans) + + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + + end subroutine z_csr_cssv + + + + subroutine z_csr_cssm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + + character :: trans_ + integer :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: tmp(:,:) + logical :: tra + Integer :: err_act + character(len=20) :: name='z_csr_csmm' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + call z_csr_cssm_impl(alpha,a,x,beta,y,info,trans) + call psb_erractionrestore(err_act) + return + + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_cssm + + function z_csr_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + + res = z_csr_csnmi_impl(a) + + return + + end function z_csr_csnmi + + subroutine z_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act, mnm, i, j, k + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + + do i=1, mnm + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j==i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + do i=mnm+1,size(d) + d(i) = zzero + end do + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_get_diag + + + subroutine z_csr_scal(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + m = a%get_nrows() + if (size(d) < m) then + info=35 + call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_scal + + + subroutine z_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csr_scals + + + +end module psb_z_csr_mat_mod diff --git a/base/modules/psb_z_mat_mod.f03 b/base/modules/psb_z_mat_mod.f03 new file mode 100644 index 00000000..b28a288b --- /dev/null +++ b/base/modules/psb_z_mat_mod.f03 @@ -0,0 +1,1924 @@ +module psb_z_mat_mod + + use psb_z_base_mat_mod + use psb_z_csr_mat_mod + + type :: psb_z_sparse_mat + + class(psb_z_base_sparse_mat), allocatable :: a + + contains + ! Setters + procedure, pass(a) :: set_nrows + procedure, pass(a) :: set_ncols + procedure, pass(a) :: set_dupl + procedure, pass(a) :: set_state + procedure, pass(a) :: set_null + procedure, pass(a) :: set_bld + procedure, pass(a) :: set_upd + procedure, pass(a) :: set_asb + procedure, pass(a) :: set_sorted + procedure, pass(a) :: set_upper + procedure, pass(a) :: set_lower + procedure, pass(a) :: set_triangle + procedure, pass(a) :: set_unit + ! Getters + procedure, pass(a) :: get_nrows + procedure, pass(a) :: get_ncols + procedure, pass(a) :: get_nzeros + procedure, pass(a) :: get_nz_row + procedure, pass(a) :: get_size + procedure, pass(a) :: get_state + procedure, pass(a) :: get_dupl + procedure, pass(a) :: is_null + procedure, pass(a) :: is_bld + procedure, pass(a) :: is_upd + procedure, pass(a) :: is_asb + procedure, pass(a) :: is_sorted + procedure, pass(a) :: is_upper + procedure, pass(a) :: is_lower + procedure, pass(a) :: is_triangle + procedure, pass(a) :: is_unit + procedure, pass(a) :: get_fmt => sparse_get_fmt + procedure, pass(a) :: sizeof => z_sizeof + + + ! Memory/data management + procedure, pass(a) :: csall + procedure, pass(a) :: free + procedure, pass(a) :: trim + procedure, pass(a) :: csput + procedure, pass(a) :: z_csgetptn + procedure, pass(a) :: z_csgetrow + procedure, pass(a) :: z_csgetblk + generic, public :: csget => z_csgetptn, z_csgetrow, z_csgetblk + procedure, pass(a) :: csclip + procedure, pass(a) :: reall => reallocate_nz + procedure, pass(a) :: get_neigh + procedure, pass(a) :: z_cscnv + procedure, pass(a) :: z_cscnv_ip + generic, public :: cscnv => z_cscnv, z_cscnv_ip + procedure, pass(a) :: reinit + procedure, pass(a) :: print => sparse_print + procedure, pass(a) :: z_mv_from + generic, public :: mv_from => z_mv_from + procedure, pass(a) :: z_cp_from + generic, public :: cp_from => z_cp_from + + + ! Computational routines + procedure, pass(a) :: get_diag + procedure, pass(a) :: csnmi + procedure, pass(a) :: z_csmv + procedure, pass(a) :: z_csmm + generic, public :: csmm => z_csmm, z_csmv + procedure, pass(a) :: z_scals + procedure, pass(a) :: z_scal + generic, public :: scal => z_scals, z_scal + procedure, pass(a) :: z_cssv + procedure, pass(a) :: z_cssm + generic, public :: cssm => z_cssm, z_cssv + + end type psb_z_sparse_mat + + private :: get_nrows, get_ncols, get_nzeros, get_size, & + & get_state, get_dupl, is_null, is_bld, is_upd, & + & is_asb, is_sorted, is_upper, is_lower, is_triangle, & + & is_unit, get_neigh, csall, csput, z_csgetrow,& + & z_csgetblk, csclip, z_cscnv, z_cscnv_ip, & + & reallocate_nz, free, trim, & + & sparse_print, reinit, & + & set_nrows, set_ncols, set_dupl, & + & set_state, set_null, set_bld, & + & set_upd, set_asb, set_sorted, & + & set_upper, set_lower, set_triangle, & + & set_unit, get_diag, get_nz_row, z_csgetptn, & + & z_mv_from, z_cp_from + + interface psb_sizeof + module procedure z_sizeof + end interface + + interface psb_move_alloc + module procedure z_sparse_mat_move + end interface + + interface psb_clone + module procedure z_sparse_mat_clone + end interface + + interface psb_csmm + module procedure z_csmm, z_csmv + end interface + + interface psb_cssm + module procedure z_cssm, z_cssv + end interface + + interface psb_csnmi + module procedure csnmi + end interface + + interface psb_scal + module procedure z_scals, z_scal + end interface + +contains + + + !===================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + !===================================== + + + function z_sizeof(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + integer(psb_long_int_k_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function z_sizeof + + + + function sparse_get_fmt(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function sparse_get_fmt + + + + function get_dupl(a) result(res) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + integer :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function get_dupl + + + function get_state(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + integer :: res + + if (allocated(a%a)) then + res = a%a%get_state() + else + res = psb_spmat_null_ + end if + end function get_state + + function get_nrows(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + integer :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function get_nrows + + function get_ncols(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + integer :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function get_ncols + + function is_triangle(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function is_triangle + + function is_unit(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function is_unit + + function is_upper(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function is_upper + + function is_lower(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function is_lower + + function is_null(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function is_null + + function is_bld(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function is_bld + + function is_upd(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function is_upd + + function is_asb(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function is_asb + + function is_sorted(a) result(res) + implicit none + class(psb_z_sparse_mat), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function is_sorted + + + + function get_nzeros(a) result(res) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%get_nzeros() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end function get_nzeros + + function get_size(a) result(res) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act, info + character(len=20) :: name='get_size' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%get_size() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end function get_size + + + function get_nz_row(idx,a) result(res) + use psb_error_mod + implicit none + integer, intent(in) :: idx + class(psb_z_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function get_nz_row + + + + !===================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + !===================================== + + + subroutine set_nrows(m,a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: m + Integer :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_nrows + + subroutine set_ncols(n,a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_ncols + + + subroutine set_state(n,a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_state(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_state + + + subroutine set_dupl(n,a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(in) :: n + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_dupl + + subroutine set_null(a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_null + + subroutine set_bld(a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_bld + + subroutine set_upd(a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + + end subroutine set_upd + + subroutine set_asb(a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_asb + + subroutine set_sorted(a,val) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_sorted + + subroutine set_triangle(a,val) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_triangle + + subroutine set_unit(a,val) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_unit + + subroutine set_lower(a,val) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_lower + + subroutine set_upper(a,val) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine set_upper + + + !===================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + !===================================== + + + subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + use psb_error_mod + implicit none + + integer, intent(in) :: iout + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + + Integer :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = 0 + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine sparse_print + + + + subroutine get_neigh(a,idx,neigh,n,info,lev) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine get_neigh + + + subroutine csall(nr,nc,a,info,nz) + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz + + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + allocate(psb_z_coo_sparse_mat :: a%a, stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine csall + + subroutine reallocate_nz(nz,a) + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine reallocate_nz + + subroutine free(a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%free() + deallocate(a%a) + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine free + + subroutine trim(a) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine trim + + + subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) + + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.a%is_bld()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine csput + + subroutine z_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine z_csgetptn + + subroutine z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + integer, intent(in) :: imin,imax + integer, intent(out) :: nz + integer, allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine z_csgetrow + + + + subroutine z_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(in) :: imin,imax + integer,intent(out) :: info + logical, intent(in), optional :: append + integer, intent(in), optional :: iren(:) + integer, intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + + if (info == 0) call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine z_csgetblk + + + + subroutine csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + implicit none + + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer,intent(out) :: info + integer, intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + Integer :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat), allocatable :: acoo + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + if (info == 0) call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info == 0) call move_alloc(acoo,b%a) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine csclip + + + + subroutine z_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + + + class(psb_z_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_z_coo_sparse_mat :: altmp, stat=info) + case default + info = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%set_asb() + call b%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine z_cscnv + + + subroutine z_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + implicit none + + class(psb_z_sparse_mat), intent(inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + + + class(psb_z_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_z_coo_sparse_mat :: altmp, stat=info) + case default + info = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine z_cscnv_ip + + subroutine z_mv_from(a,b) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer :: info + + allocate(a%a,source=b, stat=info) + call a%a%mv_from_fmt(b,info) + + return + end subroutine z_mv_from + + subroutine z_cp_from(a,b) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_sparse_mat), intent(out) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b + Integer :: err_act, info + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(a%a,source=b,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call a%a%cp_from_fmt(b, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + end subroutine z_cp_from + + subroutine z_sparse_mat_move(a,b,info) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = 0 + call move_alloc(a%a,b%a) + + return + end subroutine z_sparse_mat_move + + subroutine z_sparse_mat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + class(psb_z_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + + allocate(b%a,source=a%a,stat=info) + if (info /= 0) info = 4000 + if (info == 0) call b%a%cp_from_fmt(a%a, info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine z_sparse_mat_clone + + + subroutine reinit(a,clear) + use psb_error_mod + implicit none + + class(psb_z_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + Integer :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reinit(clear) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + + end subroutine reinit + + + !===================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + !===================================== + + + subroutine z_csmm(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csmm + + subroutine z_csmv(alpha,a,x,beta,y,info,trans) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans + Integer :: err_act + character(len=20) :: name='psb_csmv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csmm(alpha,x,beta,y,info,trans) + if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_csmv + + subroutine z_cssm(alpha,a,x,beta,y,info,trans,side,d) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, side + complex(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,side,d) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_cssm + + subroutine z_cssv(alpha,a,x,beta,y,info,trans,side,d) + use psb_error_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer, intent(out) :: info + character, optional, intent(in) :: trans, side + complex(psb_dpk_), intent(in), optional :: d(:) + Integer :: err_act + character(len=20) :: name='psb_cssv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cssm(alpha,x,beta,y,info,trans,side,d) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_cssv + + + function csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + Integer :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%csnmi() + + + return + +9999 continue + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end function csnmi + + + + subroutine get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_diag(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine get_diag + + subroutine z_scal(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_scal + + subroutine z_scals(d,a,info) + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine z_scals + + +end module psb_z_mat_mod diff --git a/base/serial/f03/Makefile b/base/serial/f03/Makefile index b755527a..d1f7342b 100644 --- a/base/serial/f03/Makefile +++ b/base/serial/f03/Makefile @@ -3,7 +3,8 @@ include ../../../Make.inc # # The object files # -FOBJS = psb_s_csr_impl.o psb_s_coo_impl.o psb_d_csr_impl.o psb_d_coo_impl.o +FOBJS = psb_s_csr_impl.o psb_s_coo_impl.o psb_d_csr_impl.o psb_d_coo_impl.o\ + psb_c_csr_impl.o psb_c_coo_impl.o psb_z_csr_impl.o psb_z_coo_impl.o OBJS=$(FOBJS) diff --git a/base/serial/f03/psb_c_coo_impl.f03 b/base/serial/f03/psb_c_coo_impl.f03 new file mode 100644 index 00000000..51204b29 --- /dev/null +++ b/base/serial/f03/psb_c_coo_impl.f03 @@ -0,0 +1,2673 @@ + +subroutine c_coo_cssm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_c_base_mat_mod, psb_protect_name => c_coo_cssm_impl + 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_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + 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() + 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 /= 0) then + info=4010 + 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 /= 0) then + info=4010 + 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 = 0 + allocate(acc(nc), stat=info) + if(info /= 0) then + info=4010 + return + end if + + + if (.not.sorted) then + info = 1121 + 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 c_coo_cssm_impl + + + +subroutine c_coo_cssv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_c_base_mat_mod, psb_protect_name => c_coo_cssv_impl + 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 = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = 1121 + 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 = 1121 + 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 /= 0) 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 /= 0) then + info=4010 + 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 /= 0) 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 = 0 + if (.not.sorted) then + info = 1121 + 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 c_coo_cssv_impl + +subroutine c_coo_csmv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_c_base_mat_mod, psb_protect_name => c_coo_csMv_impl + 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 = 0 + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + 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 + 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 c_coo_csmv_impl + + +subroutine c_coo_csmm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_c_base_mat_mod, psb_protect_name => c_coo_csmm_impl + 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 = 0 + call psb_erractionsave(err_act) + + + if (.not.a%is_asb()) then + info = 1121 + 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 + nnz = a%get_nzeros() + + nc = min(size(x,2), size(y,2)) + allocate(acc(nc),stat=info) + if(info /= 0) then + info=4010 + 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 c_coo_csmm_impl + +function c_coo_csnmi_impl(a) result(res) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => c_coo_csnmi_impl + 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 c_coo_csnmi_impl + + + +!==================================== +! +! +! +! Data management +! +! +! +! +! +!==================================== + + + +subroutine c_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => c_coo_csgetptn_impl + 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 = 0 + + 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= 0) 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 c_coo_csgetptn_impl + + +subroutine c_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => c_coo_csgetrow_impl + 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 = 0 + + 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) 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 c_coo_csgetrow_impl + + +subroutine c_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_c_base_mat_mod, psb_protect_name => c_coo_csput_impl + 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 = 0 + call psb_erractionsave(err_act) + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + 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 /= 0) then + info = 1121 + end if + + else + ! State is wrong. + info = 1121 + end if + if (info /= 0) 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 = 0 + 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 = 0 + 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 c_coo_csput_impl + + +subroutine c_cp_coo_to_coo_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => c_cp_coo_to_coo_impl + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + b%ia(:) = a%ia(:) + b%ja(:) = a%ja(:) + b%val(:) = a%val(:) + + call b%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine c_cp_coo_to_coo_impl + +subroutine c_cp_coo_from_coo_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => c_cp_coo_from_coo_impl + implicit none + class(psb_c_coo_sparse_mat), intent(out) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + a%ia(:) = b%ia(:) + a%ja(:) = b%ja(:) + a%val(:) = b%val(:) + + call a%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine c_cp_coo_from_coo_impl + + +subroutine c_cp_coo_to_fmt_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => c_cp_coo_to_fmt_impl + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_from_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine c_cp_coo_to_fmt_impl + +subroutine c_cp_coo_from_fmt_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => c_cp_coo_from_fmt_impl + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine c_cp_coo_from_fmt_impl + + +subroutine c_fix_coo_impl(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_string_mod + use psb_ip_reord_mod + use psb_c_base_mat_mod, psb_protect_name => c_fix_coo_impl + 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 = 0 + + 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 c_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + + 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 c_fix_coo_impl + + + +subroutine c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => c_fix_coo_inner + use psb_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 = 0 + + 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 /= 0) 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(130,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(0,*) 'Error in fix_coo: unsafe dupl',dupl_ + + 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(130,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(0,*) 'Error in fix_coo: unsafe dupl',dupl_ + 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 c_fix_coo_inner + + + + +subroutine c_mv_coo_to_coo_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => c_mv_coo_to_coo_impl + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + call b%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine c_mv_coo_to_coo_impl + +subroutine c_mv_coo_from_coo_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => c_mv_coo_from_coo_impl + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + + a%ia(:) = b%ia(:) + a%ja(:) = b%ja(:) + a%val(:) = b%val(:) + + call a%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine c_mv_coo_from_coo_impl + + +subroutine c_mv_coo_to_fmt_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => c_mv_coo_to_fmt_impl + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + + call b%mv_from_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine c_mv_coo_to_fmt_impl + +subroutine c_mv_coo_from_fmt_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => c_mv_coo_from_fmt_impl + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + + call b%mv_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine c_mv_coo_from_fmt_impl diff --git a/base/serial/f03/psb_c_csr_impl.f03 b/base/serial/f03/psb_c_csr_impl.f03 new file mode 100644 index 00000000..69714b9b --- /dev/null +++ b/base/serial/f03/psb_c_csr_impl.f03 @@ -0,0 +1,2209 @@ + +!===================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!===================================== + +subroutine c_csr_csmv_impl(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_c_csr_mat_mod, psb_protect_name => c_csr_csmv_impl + 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 = 0 + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = 1121 + 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 + + call c_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,& + & a%is_triangle(),a%is_unit(),& + & x,beta,y,tra,ctra) + + call psb_erractionrestore(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 c_csr_csmv_inner(m,n,alpha,irp,ja,val,is_triangle,is_unit,& + & x,beta,y,tra,ctra) + integer, intent(in) :: m,n,irp(*),ja(*) + complex(psb_spk_), intent(in) :: alpha, beta, x(*),val(*) + complex(psb_spk_), intent(inout) :: y(*) + logical, intent(in) :: is_triangle,is_unit,tra, ctra + + + integer :: i,j,k, ir, jc + complex(psb_spk_) :: acc + + 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 ((.not.tra).and.(.not.ctra)) then + + if (beta == dzero) then + + if (alpha == done) then + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = acc + end do + + else if (alpha == -done) then + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = -acc + end do + + else + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = alpha*acc + end do + + end if + + + else if (beta == done) then + + if (alpha == done) then + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = y(i) + acc + end do + + else if (alpha == -done) then + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = y(i) -acc + end do + + else + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = y(i) + alpha*acc + end do + + end if + + else if (beta == -done) then + + if (alpha == done) then + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = -y(i) + acc + end do + + else if (alpha == -done) then + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = -y(i) -acc + end do + + else + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = -y(i) + alpha*acc + end do + + end if + + else + + if (alpha == done) then + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = beta*y(i) + acc + end do + + else if (alpha == -done) then + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = beta*y(i) - acc + end do + + else + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = beta*y(i) + alpha*acc + end do + + end if + + end if + + else if (tra) then + + if (beta == dzero) then + do i=1, m + y(i) = dzero + end do + else if (beta == done) then + ! Do nothing + else if (beta == -done) then + do i=1, m + y(i) = -y(i) + end do + else + do i=1, m + y(i) = beta*y(i) + end do + end if + + if (alpha == done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) + val(j)*x(i) + end do + enddo + + else if (alpha == -done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) - val(j)*x(i) + end do + enddo + + else + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) + alpha*val(j)*x(i) + end do + enddo + + end if + + else if (ctra) then + + if (beta == dzero) then + do i=1, m + y(i) = dzero + end do + else if (beta == done) then + ! Do nothing + else if (beta == -done) then + do i=1, m + y(i) = -y(i) + end do + else + do i=1, m + y(i) = beta*y(i) + end do + end if + + if (alpha == done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) + conjg(val(j))*x(i) + end do + enddo + + else if (alpha == -done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) - conjg(val(j))*x(i) + end do + enddo + + else + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) + alpha*conjg(val(j))*x(i) + end do + enddo + + end if + + endif + + if (is_triangle.and.is_unit) then + do i=1, min(m,n) + y(i) = y(i) + alpha*x(i) + end do + end if + + + end subroutine c_csr_csmv_inner + + +end subroutine c_csr_csmv_impl + +subroutine c_csr_csmm_impl(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_c_csr_mat_mod, psb_protect_name => c_csr_csmm_impl + 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 = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = 1121 + 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 + + nc = min(size(x,2) , size(y,2) ) + + allocate(acc(nc), stat=info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call c_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, & + & a%is_triangle(),a%is_unit(),x,size(x,1), & + & beta,y,size(y,1),tra,ctra,acc) + + + call psb_erractionrestore(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 c_csr_csmm_inner(m,n,nc,alpha,irp,ja,val,& + & is_triangle,is_unit,x,ldx,beta,y,ldy,tra,ctra,acc) + integer, intent(in) :: m,n,ldx,ldy,nc,irp(*),ja(*) + complex(psb_spk_), intent(in) :: alpha, beta, x(ldx,*),val(*) + complex(psb_spk_), intent(inout) :: y(ldy,*) + logical, intent(in) :: is_triangle,is_unit,tra,ctra + + complex(psb_spk_), intent(inout) :: acc(*) + integer :: i,j,k, ir, jc + + + 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 ((.not.tra).and.(.not.ctra)) then + if (beta == dzero) then + + if (alpha == done) then + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = acc(1:nc) + end do + + else if (alpha == -done) then + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = -acc(1:nc) + end do + + else + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = alpha*acc(1:nc) + end do + + end if + + + else if (beta == done) then + + if (alpha == done) then + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = y(i,1:nc) + acc(1:nc) + end do + + else if (alpha == -done) then + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = y(i,1:nc) -acc(1:nc) + end do + + else + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = y(i,1:nc) + alpha*acc(1:nc) + end do + + end if + + else if (beta == -done) then + + if (alpha == done) then + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = -y(i,1:nc) + acc(1:nc) + end do + + else if (alpha == -done) then + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = -y(i,1:nc) -acc(1:nc) + end do + + else + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = -y(i,1:nc) + alpha*acc(1:nc) + end do + + end if + + else + + if (alpha == done) then + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = beta*y(i,1:nc) + acc(1:nc) + end do + + else if (alpha == -done) then + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = beta*y(i,1:nc) - acc(1:nc) + end do + + else + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = beta*y(i,1:nc) + alpha*acc(1:nc) + end do + + end if + + end if + + else if (tra) then + + if (beta == dzero) then + do i=1, m + y(i,1:nc) = dzero + end do + else if (beta == done) then + ! Do nothing + else if (beta == -done) then + do i=1, m + y(i,1:nc) = -y(i,1:nc) + end do + else + do i=1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + end if + + if (alpha == done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) + val(j)*x(i,1:nc) + end do + enddo + + else if (alpha == -done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) - val(j)*x(i,1:nc) + end do + enddo + + else + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) + alpha*val(j)*x(i,1:nc) + end do + enddo + + end if + + else if (ctra) then + + if (beta == dzero) then + do i=1, m + y(i,1:nc) = dzero + end do + else if (beta == done) then + ! Do nothing + else if (beta == -done) then + do i=1, m + y(i,1:nc) = -y(i,1:nc) + end do + else + do i=1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + end if + + if (alpha == done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) + conjg(val(j))*x(i,1:nc) + end do + enddo + + else if (alpha == -done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) - conjg(val(j))*x(i,1:nc) + end do + enddo + + else + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) + alpha*conjg(val(j))*x(i,1:nc) + end do + enddo + + end if + + endif + + if (is_triangle.and.is_unit) then + do i=1, min(m,n) + y(i,1:nc) = y(i,1:nc) + alpha*x(i,1:nc) + end do + end if + + end subroutine c_csr_csmm_inner + +end subroutine c_csr_csmm_impl + + +subroutine c_csr_cssv_impl(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_c_csr_mat_mod, psb_protect_name => c_csr_cssv_impl + 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 = 0 + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = 1121 + 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 = 1121 + 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_csrsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),& + & a%irp,a%ja,a%val,x,y) + if (alpha == done) then + ! do nothing + else if (alpha == -done) then + do i = 1, m + y(i) = -y(i) + end do + else + do i = 1, m + y(i) = alpha*y(i) + end do + end if + else + allocate(tmp(m), stat=info) + if (info /= 0) then + return + end if + + call inner_csrsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),& + & a%irp,a%ja,a%val,x,tmp) + 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_csrsv(tra,ctra,lower,unit,n,irp,ja,val,x,y) + implicit none + logical, intent(in) :: tra,ctra,lower,unit + integer, intent(in) :: irp(*), ja(*),n + complex(psb_spk_), intent(in) :: val(*) + complex(psb_spk_), intent(in) :: x(*) + complex(psb_spk_), intent(out) :: y(*) + + integer :: i,j,k,m, ir, jc + complex(psb_spk_) :: acc + + if ((.not.tra).and.(.not.ctra)) then + + if (lower) then + if (unit) then + do i=1, n + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j)) + end do + y(i) = x(i) - acc + end do + else if (.not.unit) then + do i=1, n + acc = dzero + do j=irp(i), irp(i+1)-2 + acc = acc + val(j)*y(ja(j)) + end do + y(i) = (x(i) - acc)/val(irp(i+1)-1) + end do + end if + else if (.not.lower) then + + if (unit) then + do i=n, 1, -1 + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j)) + end do + y(i) = x(i) - acc + end do + else if (.not.unit) then + do i=n, 1, -1 + acc = dzero + do j=irp(i)+1, irp(i+1)-1 + acc = acc + val(j)*y(ja(j)) + end do + y(i) = (x(i) - acc)/val(irp(i)) + end do + end if + + end if + + else if (tra) then + + do i=1, n + y(i) = x(i) + end do + + if (lower) then + if (unit) then + do i=n, 1, -1 + acc = y(i) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=n, 1, -1 + y(i) = y(i)/val(irp(i+1)-1) + acc = y(i) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, n + acc = y(i) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=1, n + y(i) = y(i)/val(irp(i)) + acc = y(i) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + end do + end do + end if + + end if + + else if (ctra) then + + do i=1, n + y(i) = x(i) + end do + + if (lower) then + if (unit) then + do i=n, 1, -1 + acc = y(i) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=n, 1, -1 + y(i) = y(i)/val(irp(i+1)-1) + acc = y(i) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, n + acc = y(i) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=1, n + y(i) = y(i)/val(irp(i)) + acc = y(i) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + end do + end do + end if + + end if + end if + end subroutine inner_csrsv + +end subroutine c_csr_cssv_impl + + + +subroutine c_csr_cssm_impl(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_c_csr_mat_mod, psb_protect_name => c_csr_cssm_impl + 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_base_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = 1121 + 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 = 1121 + 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 /= 0) then + info=4010 + 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 /= 0) then + info=4010 + 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 = 0 + allocate(acc(nc), stat=info) + if(info /= 0) then + info=4010 + 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 c_csr_cssm_impl + +function c_csr_csnmi_impl(a) result(res) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => c_csr_csnmi_impl + 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 c_csr_csnmi_impl + +!===================================== +! +! +! +! Data management +! +! +! +! +! +!===================================== + + +subroutine c_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => c_csr_csgetptn_impl + 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 = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax c_csr_csgetrow_impl + 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 = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax c_csr_csput_impl + 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) + + info = 0 + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = 1121 + + else if (a%is_upd()) then + call c_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= 0) then + + info = 1121 + end if + + else + ! State is wrong. + info = 1121 + end if + if (info /= 0) 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 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 = 0 + 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 c_csr_srch_upd + +end subroutine c_csr_csput_impl + + + +subroutine c_cp_csr_from_coo_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => c_cp_csr_from_coo_impl + 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 = 0 + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info ==0) call a%mv_from_coo(tmp,info) + +end subroutine c_cp_csr_from_coo_impl + + + +subroutine c_cp_csr_to_coo_impl(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => c_cp_csr_to_coo_impl + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + integer, 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 = 0 + + 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 c_cp_csr_to_coo_impl + + +subroutine c_mv_csr_to_coo_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => c_mv_csr_to_coo_impl + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + integer, 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 = 0 + + 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 /= 0) 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 c_mv_csr_to_coo_impl + + + +subroutine c_mv_csr_from_coo_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => c_mv_csr_from_coo_impl + 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 = 0 + + call b%fix(info) + if (info /= 0) 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 c_mv_csr_from_coo_impl + + +subroutine c_mv_csr_to_fmt_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => c_mv_csr_to_fmt_impl + implicit none + + class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(out) :: 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 = 0 + + 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 tmp%mv_from_fmt(a,info) + if (info == 0) call b%mv_from_coo(tmp,info) + end select + +end subroutine c_mv_csr_to_fmt_impl + + +subroutine c_cp_csr_to_fmt_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => c_cp_csr_to_fmt_impl + implicit none + + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: 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 = 0 + + + select type (b) + type is (psb_c_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_c_csr_sparse_mat) + b = a + + class default + call tmp%cp_from_fmt(a,info) + if (info == 0) call b%mv_from_coo(tmp,info) + end select + +end subroutine c_cp_csr_to_fmt_impl + + +subroutine c_mv_csr_from_fmt_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => c_mv_csr_from_fmt_impl + 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 = 0 + + 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 tmp%mv_from_fmt(b,info) + if (info == 0) call a%mv_from_coo(tmp,info) + end select + +end subroutine c_mv_csr_from_fmt_impl + + + +subroutine c_cp_csr_from_fmt_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => c_cp_csr_from_fmt_impl + 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 = 0 + + 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 tmp%cp_from_fmt(b,info) + if (info == 0) call a%mv_from_coo(tmp,info) + end select +end subroutine c_cp_csr_from_fmt_impl + diff --git a/base/serial/f03/psb_d_coo_impl.f03 b/base/serial/f03/psb_d_coo_impl.f03 index 7d063d55..a8875add 100644 --- a/base/serial/f03/psb_d_coo_impl.f03 +++ b/base/serial/f03/psb_d_coo_impl.f03 @@ -543,6 +543,7 @@ end subroutine d_coo_cssv_impl subroutine d_coo_csmv_impl(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod + use psb_string_mod use psb_d_base_mat_mod, psb_protect_name => d_coo_csMv_impl implicit none @@ -576,8 +577,7 @@ subroutine d_coo_csmv_impl(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - tra = ((trans_=='T').or.(trans_=='t')) - + tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') if (tra) then @@ -701,6 +701,7 @@ end subroutine d_coo_csmv_impl subroutine d_coo_csmm_impl(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod + use psb_string_mod use psb_d_base_mat_mod, psb_protect_name => d_coo_csmm_impl implicit none class(psb_d_coo_sparse_mat), intent(in) :: a @@ -735,7 +736,7 @@ subroutine d_coo_csmm_impl(alpha,a,x,beta,y,info,trans) end if - tra = ((trans_=='T').or.(trans_=='t')) + tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') if (tra) then m = a%get_ncols() diff --git a/base/serial/f03/psb_d_csr_impl.f03 b/base/serial/f03/psb_d_csr_impl.f03 index 98d9baa0..e627c7c6 100644 --- a/base/serial/f03/psb_d_csr_impl.f03 +++ b/base/serial/f03/psb_d_csr_impl.f03 @@ -589,6 +589,7 @@ end subroutine d_csr_csmm_impl subroutine d_csr_cssv_impl(alpha,a,x,beta,y,info,trans) use psb_error_mod + use psb_string_mod use psb_d_csr_mat_mod, psb_protect_name => d_csr_cssv_impl implicit none class(psb_d_csr_sparse_mat), intent(in) :: a @@ -619,7 +620,7 @@ subroutine d_csr_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = ((trans_=='T').or.(trans_=='t')) + tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (.not. (a%is_triangle())) then @@ -793,6 +794,7 @@ end subroutine d_csr_cssv_impl subroutine d_csr_cssm_impl(alpha,a,x,beta,y,info,trans) use psb_error_mod + use psb_string_mod use psb_d_csr_mat_mod, psb_protect_name => d_csr_cssm_impl implicit none class(psb_d_csr_sparse_mat), intent(in) :: a @@ -825,7 +827,8 @@ subroutine d_csr_cssm_impl(alpha,a,x,beta,y,info,trans) endif - tra = ((trans_=='T').or.(trans_=='t')) + tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() nc = min(size(x,2) , size(y,2)) @@ -917,18 +920,18 @@ contains if (unit) then do i=1, nr acc = dzero - do j=a%irp(i), a%irp(i+1)-1 - acc = acc + a%val(j)*y(a%ja(j),1:nc) + 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=a%irp(i), a%irp(i+1)-2 - acc = acc + a%val(j)*y(a%ja(j),1:nc) + 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)/a%val(a%irp(i+1)-1) + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) end do end if else if (.not.lower) then @@ -936,18 +939,18 @@ contains if (unit) then do i=nr, 1, -1 acc = dzero - do j=a%irp(i), a%irp(i+1)-1 - acc = acc + a%val(j)*y(a%ja(j),1:nc) + 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=a%irp(i)+1, a%irp(i+1)-1 - acc = acc + a%val(j)*y(a%ja(j),1:nc) + 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)/a%val(a%irp(i)) + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i)) end do end if @@ -963,18 +966,18 @@ contains if (unit) then do i=nr, 1, -1 acc = y(i,1:nc) - do j=a%irp(i), a%irp(i+1)-1 - jc = a%ja(j) - y(jc,1:nc) = y(jc,1:nc) - a%val(j)*acc + 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)/a%val(a%irp(i+1)-1) + y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) acc = y(i,1:nc) - do j=a%irp(i), a%irp(i+1)-2 - jc = a%ja(j) - y(jc,1:nc) = y(jc,1:nc) - a%val(j)*acc + 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 @@ -983,18 +986,18 @@ contains if (unit) then do i=1, nr acc = y(i,1:nc) - do j=a%irp(i), a%irp(i+1)-1 - jc = a%ja(j) - y(jc,1:nc) = y(jc,1:nc) - a%val(j)*acc + 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)/a%val(a%irp(i)) + y(i,1:nc) = y(i,1:nc)/val(irp(i)) acc = y(i,1:nc) - do j=a%irp(i)+1, a%irp(i+1)-1 - jc = a%ja(j) - y(jc,1:nc) = y(jc,1:nc) - a%val(j)*acc + 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 diff --git a/base/serial/f03/psb_s_coo_impl.f03 b/base/serial/f03/psb_s_coo_impl.f03 index f4ede38b..e79517a9 100644 --- a/base/serial/f03/psb_s_coo_impl.f03 +++ b/base/serial/f03/psb_s_coo_impl.f03 @@ -543,6 +543,7 @@ end subroutine s_coo_cssv_impl subroutine s_coo_csmv_impl(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod + use psb_string_mod use psb_s_base_mat_mod, psb_protect_name => s_coo_csMv_impl implicit none @@ -576,9 +577,7 @@ subroutine s_coo_csmv_impl(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - tra = ((trans_=='T').or.(trans_=='t')) - - + tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') if (tra) then m = a%get_ncols() @@ -701,6 +700,7 @@ end subroutine s_coo_csmv_impl subroutine s_coo_csmm_impl(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod + use psb_string_mod use psb_s_base_mat_mod, psb_protect_name => s_coo_csmm_impl implicit none class(psb_s_coo_sparse_mat), intent(in) :: a @@ -734,8 +734,7 @@ subroutine s_coo_csmm_impl(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - - tra = ((trans_=='T').or.(trans_=='t')) + tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') if (tra) then m = a%get_ncols() diff --git a/base/serial/f03/psb_s_csr_impl.f03 b/base/serial/f03/psb_s_csr_impl.f03 index 5de1dae7..a30b1f3f 100644 --- a/base/serial/f03/psb_s_csr_impl.f03 +++ b/base/serial/f03/psb_s_csr_impl.f03 @@ -589,6 +589,7 @@ end subroutine s_csr_csmm_impl subroutine s_csr_cssv_impl(alpha,a,x,beta,y,info,trans) use psb_error_mod + use psb_string_mod use psb_s_csr_mat_mod, psb_protect_name => s_csr_cssv_impl implicit none class(psb_s_csr_sparse_mat), intent(in) :: a @@ -619,7 +620,8 @@ subroutine s_csr_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = ((trans_=='T').or.(trans_=='t')) + tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + m = a%get_nrows() @@ -804,6 +806,7 @@ end subroutine s_csr_cssv_impl subroutine s_csr_cssm_impl(alpha,a,x,beta,y,info,trans) use psb_error_mod + use psb_string_mod use psb_s_csr_mat_mod, psb_protect_name => s_csr_cssm_impl implicit none class(psb_s_csr_sparse_mat), intent(in) :: a @@ -836,7 +839,7 @@ subroutine s_csr_cssm_impl(alpha,a,x,beta,y,info,trans) endif - tra = ((trans_=='T').or.(trans_=='t')) + tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() nc = min(size(x,2) , size(y,2)) @@ -928,18 +931,18 @@ contains if (unit) then do i=1, nr acc = szero - do j=a%irp(i), a%irp(i+1)-1 - acc = acc + a%val(j)*y(a%ja(j),1:nc) + 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 = szero - do j=a%irp(i), a%irp(i+1)-2 - acc = acc + a%val(j)*y(a%ja(j),1:nc) + 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)/a%val(a%irp(i+1)-1) + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) end do end if else if (.not.lower) then @@ -947,18 +950,18 @@ contains if (unit) then do i=nr, 1, -1 acc = szero - do j=a%irp(i), a%irp(i+1)-1 - acc = acc + a%val(j)*y(a%ja(j),1:nc) + 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 = szero - do j=a%irp(i)+1, a%irp(i+1)-1 - acc = acc + a%val(j)*y(a%ja(j),1:nc) + 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)/a%val(a%irp(i)) + y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i)) end do end if @@ -974,18 +977,18 @@ contains if (unit) then do i=nr, 1, -1 acc = y(i,1:nc) - do j=a%irp(i), a%irp(i+1)-1 - jc = a%ja(j) - y(jc,1:nc) = y(jc,1:nc) - a%val(j)*acc + 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)/a%val(a%irp(i+1)-1) + y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) acc = y(i,1:nc) - do j=a%irp(i), a%irp(i+1)-2 - jc = a%ja(j) - y(jc,1:nc) = y(jc,1:nc) - a%val(j)*acc + 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 @@ -994,18 +997,18 @@ contains if (unit) then do i=1, nr acc = y(i,1:nc) - do j=a%irp(i), a%irp(i+1)-1 - jc = a%ja(j) - y(jc,1:nc) = y(jc,1:nc) - a%val(j)*acc + 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)/a%val(a%irp(i)) + y(i,1:nc) = y(i,1:nc)/val(irp(i)) acc = y(i,1:nc) - do j=a%irp(i)+1, a%irp(i+1)-1 - jc = a%ja(j) - y(jc,1:nc) = y(jc,1:nc) - a%val(j)*acc + 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 diff --git a/base/serial/f03/psb_z_coo_impl.f03 b/base/serial/f03/psb_z_coo_impl.f03 new file mode 100644 index 00000000..57b73311 --- /dev/null +++ b/base/serial/f03/psb_z_coo_impl.f03 @@ -0,0 +1,2673 @@ + +subroutine z_coo_cssm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_z_base_mat_mod, psb_protect_name => z_coo_cssm_impl + 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_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + + if (.not. (a%is_triangle())) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + 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() + 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 /= 0) then + info=4010 + 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 /= 0) then + info=4010 + 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 = 0 + allocate(acc(nc), stat=info) + if(info /= 0) then + info=4010 + return + end if + + + if (.not.sorted) then + info = 1121 + 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 z_coo_cssm_impl + + + +subroutine z_coo_cssv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_z_base_mat_mod, psb_protect_name => z_coo_cssv_impl + 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 = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = 1121 + 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 = 1121 + 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 /= 0) 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 /= 0) then + info=4010 + 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 /= 0) 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 = 0 + if (.not.sorted) then + info = 1121 + 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 z_coo_cssv_impl + +subroutine z_coo_csmv_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_z_base_mat_mod, psb_protect_name => z_coo_csMv_impl + 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 = 0 + call psb_erractionsave(err_act) + + if (.not.a%is_asb()) then + info = 1121 + 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 + 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 z_coo_csmv_impl + + +subroutine z_coo_csmm_impl(alpha,a,x,beta,y,info,trans) + use psb_const_mod + use psb_error_mod + use psb_string_mod + use psb_z_base_mat_mod, psb_protect_name => z_coo_csmm_impl + 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 = 0 + call psb_erractionsave(err_act) + + + if (.not.a%is_asb()) then + info = 1121 + 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 + nnz = a%get_nzeros() + + nc = min(size(x,2), size(y,2)) + allocate(acc(nc),stat=info) + if(info /= 0) then + info=4010 + 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 z_coo_csmm_impl + +function z_coo_csnmi_impl(a) result(res) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => z_coo_csnmi_impl + 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 z_coo_csnmi_impl + + + +!==================================== +! +! +! +! Data management +! +! +! +! +! +!==================================== + + + +subroutine z_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => z_coo_csgetptn_impl + 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 = 0 + + 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= 0) 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 z_coo_csgetptn_impl + + +subroutine z_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => z_coo_csgetrow_impl + 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 = 0 + + 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) 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==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= 0) 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 z_coo_csgetrow_impl + + +subroutine z_coo_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_z_base_mat_mod, psb_protect_name => z_coo_csput_impl + 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 = 0 + call psb_erractionsave(err_act) + + if (nz <= 0) then + info = 10 + int_err(1)=1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(ia) < nz) then + info = 35 + int_err(1)=2 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (size(ja) < nz) then + info = 35 + int_err(1)=3 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + if (size(val) < nz) then + info = 35 + int_err(1)=4 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + 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 /= 0) then + info = 1121 + end if + + else + ! State is wrong. + info = 1121 + end if + if (info /= 0) 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 = 0 + 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 = 0 + 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 z_coo_csput_impl + + +subroutine z_cp_coo_to_coo_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => z_cp_coo_to_coo_impl + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + b%ia(:) = a%ia(:) + b%ja(:) = a%ja(:) + b%val(:) = a%val(:) + + call b%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine z_cp_coo_to_coo_impl + +subroutine z_cp_coo_from_coo_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => z_cp_coo_from_coo_impl + implicit none + class(psb_z_coo_sparse_mat), intent(out) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + a%ia(:) = b%ia(:) + a%ja(:) = b%ja(:) + a%val(:) = b%val(:) + + call a%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine z_cp_coo_from_coo_impl + + +subroutine z_cp_coo_to_fmt_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => z_cp_coo_to_fmt_impl + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_from_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine z_cp_coo_to_fmt_impl + +subroutine z_cp_coo_from_fmt_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => z_cp_coo_from_fmt_impl + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + + call b%cp_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine z_cp_coo_from_fmt_impl + + +subroutine z_fix_coo_impl(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_string_mod + use psb_ip_reord_mod + use psb_z_base_mat_mod, psb_protect_name => z_fix_coo_impl + 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 = 0 + + 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 z_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + + 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 z_fix_coo_impl + + + +subroutine z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => z_fix_coo_inner + use psb_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 = 0 + + 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 /= 0) 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(130,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(0,*) 'Error in fix_coo: unsafe dupl',dupl_ + + 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(130,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(0,*) 'Error in fix_coo: unsafe dupl',dupl_ + 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 z_fix_coo_inner + + + + +subroutine z_mv_coo_to_coo_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => z_mv_coo_to_coo_impl + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call b%set_nzeros(a%get_nzeros()) + call b%reallocate(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + + call b%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine z_mv_coo_to_coo_impl + +subroutine z_mv_coo_from_coo_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => z_mv_coo_from_coo_impl + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call a%set_nzeros(b%get_nzeros()) + call a%reallocate(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + + a%ia(:) = b%ia(:) + a%ja(:) = b%ja(:) + a%val(:) = b%val(:) + + call a%fix(info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine z_mv_coo_from_coo_impl + + +subroutine z_mv_coo_to_fmt_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => z_mv_coo_to_fmt_impl + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + + call b%mv_from_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine z_mv_coo_to_fmt_impl + +subroutine z_mv_coo_from_fmt_impl(a,b,info) + use psb_error_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => z_mv_coo_from_fmt_impl + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer :: m,n,nz + + + call psb_erractionsave(err_act) + info = 0 + + call b%mv_to_coo(a,info) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + call psb_errpush(info,name) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine z_mv_coo_from_fmt_impl diff --git a/base/serial/f03/psb_z_csr_impl.f03 b/base/serial/f03/psb_z_csr_impl.f03 new file mode 100644 index 00000000..aaf82b0d --- /dev/null +++ b/base/serial/f03/psb_z_csr_impl.f03 @@ -0,0 +1,2209 @@ + +!===================================== +! +! +! +! Computational routines +! +! +! +! +! +! +!===================================== + +subroutine z_csr_csmv_impl(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_z_csr_mat_mod, psb_protect_name => z_csr_csmv_impl + 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 = 0 + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = 1121 + 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 + + call z_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,& + & a%is_triangle(),a%is_unit(),& + & x,beta,y,tra,ctra) + + call psb_erractionrestore(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 z_csr_csmv_inner(m,n,alpha,irp,ja,val,is_triangle,is_unit,& + & x,beta,y,tra,ctra) + integer, intent(in) :: m,n,irp(*),ja(*) + complex(psb_dpk_), intent(in) :: alpha, beta, x(*),val(*) + complex(psb_dpk_), intent(inout) :: y(*) + logical, intent(in) :: is_triangle,is_unit,tra, ctra + + + integer :: i,j,k, ir, jc + complex(psb_dpk_) :: acc + + 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 ((.not.tra).and.(.not.ctra)) then + + if (beta == dzero) then + + if (alpha == done) then + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = acc + end do + + else if (alpha == -done) then + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = -acc + end do + + else + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = alpha*acc + end do + + end if + + + else if (beta == done) then + + if (alpha == done) then + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = y(i) + acc + end do + + else if (alpha == -done) then + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = y(i) -acc + end do + + else + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = y(i) + alpha*acc + end do + + end if + + else if (beta == -done) then + + if (alpha == done) then + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = -y(i) + acc + end do + + else if (alpha == -done) then + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = -y(i) -acc + end do + + else + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = -y(i) + alpha*acc + end do + + end if + + else + + if (alpha == done) then + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = beta*y(i) + acc + end do + + else if (alpha == -done) then + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = beta*y(i) - acc + end do + + else + + do i=1,m + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j) * x(ja(j)) + enddo + y(i) = beta*y(i) + alpha*acc + end do + + end if + + end if + + else if (tra) then + + if (beta == dzero) then + do i=1, m + y(i) = dzero + end do + else if (beta == done) then + ! Do nothing + else if (beta == -done) then + do i=1, m + y(i) = -y(i) + end do + else + do i=1, m + y(i) = beta*y(i) + end do + end if + + if (alpha == done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) + val(j)*x(i) + end do + enddo + + else if (alpha == -done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) - val(j)*x(i) + end do + enddo + + else + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) + alpha*val(j)*x(i) + end do + enddo + + end if + + else if (ctra) then + + if (beta == dzero) then + do i=1, m + y(i) = dzero + end do + else if (beta == done) then + ! Do nothing + else if (beta == -done) then + do i=1, m + y(i) = -y(i) + end do + else + do i=1, m + y(i) = beta*y(i) + end do + end if + + if (alpha == done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) + conjg(val(j))*x(i) + end do + enddo + + else if (alpha == -done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) - conjg(val(j))*x(i) + end do + enddo + + else + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir) = y(ir) + alpha*conjg(val(j))*x(i) + end do + enddo + + end if + + endif + + if (is_triangle.and.is_unit) then + do i=1, min(m,n) + y(i) = y(i) + alpha*x(i) + end do + end if + + + end subroutine z_csr_csmv_inner + + +end subroutine z_csr_csmv_impl + +subroutine z_csr_csmm_impl(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_z_csr_mat_mod, psb_protect_name => z_csr_csmm_impl + 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 = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + + if (.not.a%is_asb()) then + info = 1121 + 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 + + nc = min(size(x,2) , size(y,2) ) + + allocate(acc(nc), stat=info) + if(info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='allocate') + goto 9999 + end if + + call z_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, & + & a%is_triangle(),a%is_unit(),x,size(x,1), & + & beta,y,size(y,1),tra,ctra,acc) + + + call psb_erractionrestore(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 z_csr_csmm_inner(m,n,nc,alpha,irp,ja,val,& + & is_triangle,is_unit,x,ldx,beta,y,ldy,tra,ctra,acc) + integer, intent(in) :: m,n,ldx,ldy,nc,irp(*),ja(*) + complex(psb_dpk_), intent(in) :: alpha, beta, x(ldx,*),val(*) + complex(psb_dpk_), intent(inout) :: y(ldy,*) + logical, intent(in) :: is_triangle,is_unit,tra,ctra + + complex(psb_dpk_), intent(inout) :: acc(*) + integer :: i,j,k, ir, jc + + + 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 ((.not.tra).and.(.not.ctra)) then + if (beta == dzero) then + + if (alpha == done) then + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = acc(1:nc) + end do + + else if (alpha == -done) then + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = -acc(1:nc) + end do + + else + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = alpha*acc(1:nc) + end do + + end if + + + else if (beta == done) then + + if (alpha == done) then + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = y(i,1:nc) + acc(1:nc) + end do + + else if (alpha == -done) then + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = y(i,1:nc) -acc(1:nc) + end do + + else + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = y(i,1:nc) + alpha*acc(1:nc) + end do + + end if + + else if (beta == -done) then + + if (alpha == done) then + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = -y(i,1:nc) + acc(1:nc) + end do + + else if (alpha == -done) then + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = -y(i,1:nc) -acc(1:nc) + end do + + else + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = -y(i,1:nc) + alpha*acc(1:nc) + end do + + end if + + else + + if (alpha == done) then + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = beta*y(i,1:nc) + acc(1:nc) + end do + + else if (alpha == -done) then + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = beta*y(i,1:nc) - acc(1:nc) + end do + + else + + do i=1,m + acc(1:nc) = dzero + do j=irp(i), irp(i+1)-1 + acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc) + enddo + y(i,1:nc) = beta*y(i,1:nc) + alpha*acc(1:nc) + end do + + end if + + end if + + else if (tra) then + + if (beta == dzero) then + do i=1, m + y(i,1:nc) = dzero + end do + else if (beta == done) then + ! Do nothing + else if (beta == -done) then + do i=1, m + y(i,1:nc) = -y(i,1:nc) + end do + else + do i=1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + end if + + if (alpha == done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) + val(j)*x(i,1:nc) + end do + enddo + + else if (alpha == -done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) - val(j)*x(i,1:nc) + end do + enddo + + else + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) + alpha*val(j)*x(i,1:nc) + end do + enddo + + end if + + else if (ctra) then + + if (beta == dzero) then + do i=1, m + y(i,1:nc) = dzero + end do + else if (beta == done) then + ! Do nothing + else if (beta == -done) then + do i=1, m + y(i,1:nc) = -y(i,1:nc) + end do + else + do i=1, m + y(i,1:nc) = beta*y(i,1:nc) + end do + end if + + if (alpha == done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) + conjg(val(j))*x(i,1:nc) + end do + enddo + + else if (alpha == -done) then + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) - conjg(val(j))*x(i,1:nc) + end do + enddo + + else + + do i=1,n + do j=irp(i), irp(i+1)-1 + ir = ja(j) + y(ir,1:nc) = y(ir,1:nc) + alpha*conjg(val(j))*x(i,1:nc) + end do + enddo + + end if + + endif + + if (is_triangle.and.is_unit) then + do i=1, min(m,n) + y(i,1:nc) = y(i,1:nc) + alpha*x(i,1:nc) + end do + end if + + end subroutine z_csr_csmm_inner + +end subroutine z_csr_csmm_impl + + +subroutine z_csr_cssv_impl(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_z_csr_mat_mod, psb_protect_name => z_csr_cssv_impl + 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 = 0 + call psb_erractionsave(err_act) + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = 1121 + 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 = 1121 + 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_csrsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),& + & a%irp,a%ja,a%val,x,y) + if (alpha == done) then + ! do nothing + else if (alpha == -done) then + do i = 1, m + y(i) = -y(i) + end do + else + do i = 1, m + y(i) = alpha*y(i) + end do + end if + else + allocate(tmp(m), stat=info) + if (info /= 0) then + return + end if + + call inner_csrsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),& + & a%irp,a%ja,a%val,x,tmp) + 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_csrsv(tra,ctra,lower,unit,n,irp,ja,val,x,y) + implicit none + logical, intent(in) :: tra,ctra,lower,unit + integer, intent(in) :: irp(*), ja(*),n + complex(psb_dpk_), intent(in) :: val(*) + complex(psb_dpk_), intent(in) :: x(*) + complex(psb_dpk_), intent(out) :: y(*) + + integer :: i,j,k,m, ir, jc + complex(psb_dpk_) :: acc + + if ((.not.tra).and.(.not.ctra)) then + + if (lower) then + if (unit) then + do i=1, n + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j)) + end do + y(i) = x(i) - acc + end do + else if (.not.unit) then + do i=1, n + acc = dzero + do j=irp(i), irp(i+1)-2 + acc = acc + val(j)*y(ja(j)) + end do + y(i) = (x(i) - acc)/val(irp(i+1)-1) + end do + end if + else if (.not.lower) then + + if (unit) then + do i=n, 1, -1 + acc = dzero + do j=irp(i), irp(i+1)-1 + acc = acc + val(j)*y(ja(j)) + end do + y(i) = x(i) - acc + end do + else if (.not.unit) then + do i=n, 1, -1 + acc = dzero + do j=irp(i)+1, irp(i+1)-1 + acc = acc + val(j)*y(ja(j)) + end do + y(i) = (x(i) - acc)/val(irp(i)) + end do + end if + + end if + + else if (tra) then + + do i=1, n + y(i) = x(i) + end do + + if (lower) then + if (unit) then + do i=n, 1, -1 + acc = y(i) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=n, 1, -1 + y(i) = y(i)/val(irp(i+1)-1) + acc = y(i) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, n + acc = y(i) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + end do + end do + else if (.not.unit) then + do i=1, n + y(i) = y(i)/val(irp(i)) + acc = y(i) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - val(j)*acc + end do + end do + end if + + end if + + else if (ctra) then + + do i=1, n + y(i) = x(i) + end do + + if (lower) then + if (unit) then + do i=n, 1, -1 + acc = y(i) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=n, 1, -1 + y(i) = y(i)/val(irp(i+1)-1) + acc = y(i) + do j=irp(i), irp(i+1)-2 + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + end do + end do + end if + else if (.not.lower) then + + if (unit) then + do i=1, n + acc = y(i) + do j=irp(i), irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + end do + end do + else if (.not.unit) then + do i=1, n + y(i) = y(i)/val(irp(i)) + acc = y(i) + do j=irp(i)+1, irp(i+1)-1 + jc = ja(j) + y(jc) = y(jc) - conjg(val(j))*acc + end do + end do + end if + + end if + end if + end subroutine inner_csrsv + +end subroutine z_csr_cssv_impl + + + +subroutine z_csr_cssm_impl(alpha,a,x,beta,y,info,trans) + use psb_error_mod + use psb_string_mod + use psb_z_csr_mat_mod, psb_protect_name => z_csr_cssm_impl + 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_base_cssm' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (present(trans)) then + trans_ = trans + else + trans_ = 'N' + end if + if (.not.a%is_asb()) then + info = 1121 + 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 = 1121 + 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 /= 0) then + info=4010 + 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 /= 0) then + info=4010 + 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 = 0 + allocate(acc(nc), stat=info) + if(info /= 0) then + info=4010 + 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 z_csr_cssm_impl + +function z_csr_csnmi_impl(a) result(res) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => z_csr_csnmi_impl + 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 z_csr_csnmi_impl + +!===================================== +! +! +! +! Data management +! +! +! +! +! +!===================================== + + +subroutine z_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => z_csr_csgetptn_impl + 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 = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax z_csr_csgetrow_impl + 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 = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax z_csr_csput_impl + 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) + + info = 0 + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = 1121 + + else if (a%is_upd()) then + call z_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info /= 0) then + + info = 1121 + end if + + else + ! State is wrong. + info = 1121 + end if + if (info /= 0) 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 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 = 0 + 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 z_csr_srch_upd + +end subroutine z_csr_csput_impl + + + +subroutine z_cp_csr_from_coo_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => z_cp_csr_from_coo_impl + 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 = 0 + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info ==0) call a%mv_from_coo(tmp,info) + +end subroutine z_cp_csr_from_coo_impl + + + +subroutine z_cp_csr_to_coo_impl(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => z_cp_csr_to_coo_impl + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + integer, 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 = 0 + + 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 z_cp_csr_to_coo_impl + + +subroutine z_mv_csr_to_coo_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => z_mv_csr_to_coo_impl + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info + + integer, 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 = 0 + + 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 /= 0) 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 z_mv_csr_to_coo_impl + + + +subroutine z_mv_csr_from_coo_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => z_mv_csr_from_coo_impl + 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 = 0 + + call b%fix(info) + if (info /= 0) 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 z_mv_csr_from_coo_impl + + +subroutine z_mv_csr_to_fmt_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => z_mv_csr_to_fmt_impl + implicit none + + class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(out) :: 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 = 0 + + 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 tmp%mv_from_fmt(a,info) + if (info == 0) call b%mv_from_coo(tmp,info) + end select + +end subroutine z_mv_csr_to_fmt_impl + + +subroutine z_cp_csr_to_fmt_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => z_cp_csr_to_fmt_impl + implicit none + + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: 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 = 0 + + + select type (b) + type is (psb_z_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_z_csr_sparse_mat) + b = a + + class default + call tmp%cp_from_fmt(a,info) + if (info == 0) call b%mv_from_coo(tmp,info) + end select + +end subroutine z_cp_csr_to_fmt_impl + + +subroutine z_mv_csr_from_fmt_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => z_mv_csr_from_fmt_impl + 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 = 0 + + 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 tmp%mv_from_fmt(b,info) + if (info == 0) call a%mv_from_coo(tmp,info) + end select + +end subroutine z_mv_csr_from_fmt_impl + + + +subroutine z_cp_csr_from_fmt_impl(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => z_cp_csr_from_fmt_impl + 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 = 0 + + 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 tmp%cp_from_fmt(b,info) + if (info == 0) call a%mv_from_coo(tmp,info) + end select +end subroutine z_cp_csr_from_fmt_impl +