diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index 02120f88e..0be6fdf30 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -307,3 +307,137 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee return end subroutine psb_lcsp_allgather + +subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_lcspmat_type), intent(inout) :: loca + type(psb_lcspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_lc_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_lpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_spk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lclcsp_allgather diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index 92a9044ba..144fb3636 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -307,3 +307,137 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee return end subroutine psb_ldsp_allgather + +subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ldspmat_type), intent(inout) :: loca + type(psb_ldspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_ld_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_lpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_dpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_ldldsp_allgather diff --git a/base/comm/psb_ispgather.F90 b/base/comm/psb_ispgather.F90 index fef966f8d..0fcfaba40 100644 --- a/base/comm/psb_ispgather.F90 +++ b/base/comm/psb_ispgather.F90 @@ -307,3 +307,137 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k return end subroutine psb_@LX@sp_allgather + +subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_@LX@spmat_type), intent(inout) :: loca + type(psb_@LX@spmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_@LX@_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_lpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_ipk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_@LX@@LX@sp_allgather diff --git a/base/comm/psb_lspgather.F90 b/base/comm/psb_lspgather.F90 index 914bcb8cf..aceae0199 100644 --- a/base/comm/psb_lspgather.F90 +++ b/base/comm/psb_lspgather.F90 @@ -307,3 +307,137 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k return end subroutine psb_@LX@sp_allgather + +subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_@LX@spmat_type), intent(inout) :: loca + type(psb_@LX@spmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_@LX@_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_lpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_@LX@@LX@sp_allgather diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index 0a86a28f1..9df3602b2 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -307,3 +307,137 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee return end subroutine psb_lssp_allgather + +subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_lsspmat_type), intent(inout) :: loca + type(psb_lsspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_ls_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_lpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_spk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lslssp_allgather diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index b8e99dec4..6939f0ba1 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -307,3 +307,137 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee return end subroutine psb_lzsp_allgather + +subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_lzspmat_type), intent(inout) :: loca + type(psb_lzspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_lz_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_lpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_dpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lzlzsp_allgather diff --git a/base/modules/comm/psb_c_comm_mod.f90 b/base/modules/comm/psb_c_comm_mod.f90 index 0deb379f9..c2a855102 100644 --- a/base/modules/comm/psb_c_comm_mod.f90 +++ b/base/modules/comm/psb_c_comm_mod.f90 @@ -115,6 +115,16 @@ module psb_c_comm_mod integer(psb_ipk_), intent(in), optional :: root,dupl logical, intent(in), optional :: keepnum,keeploc end subroutine psb_lcsp_allgather + subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + import + implicit none + type(psb_lcspmat_type), intent(inout) :: loca + type(psb_lcspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_lclcsp_allgather subroutine psb_cgather_vect(globx, locx, desc_a, info, root) import implicit none diff --git a/base/modules/comm/psb_d_comm_mod.f90 b/base/modules/comm/psb_d_comm_mod.f90 index 431a8aec0..5efde2b0c 100644 --- a/base/modules/comm/psb_d_comm_mod.f90 +++ b/base/modules/comm/psb_d_comm_mod.f90 @@ -115,6 +115,16 @@ module psb_d_comm_mod integer(psb_ipk_), intent(in), optional :: root,dupl logical, intent(in), optional :: keepnum,keeploc end subroutine psb_ldsp_allgather + subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + import + implicit none + type(psb_ldspmat_type), intent(inout) :: loca + type(psb_ldspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_ldldsp_allgather subroutine psb_dgather_vect(globx, locx, desc_a, info, root) import implicit none diff --git a/base/modules/comm/psb_s_comm_mod.f90 b/base/modules/comm/psb_s_comm_mod.f90 index 5e54e360b..a55e0c55e 100644 --- a/base/modules/comm/psb_s_comm_mod.f90 +++ b/base/modules/comm/psb_s_comm_mod.f90 @@ -115,6 +115,16 @@ module psb_s_comm_mod integer(psb_ipk_), intent(in), optional :: root,dupl logical, intent(in), optional :: keepnum,keeploc end subroutine psb_lssp_allgather + subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + import + implicit none + type(psb_lsspmat_type), intent(inout) :: loca + type(psb_lsspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_lslssp_allgather subroutine psb_sgather_vect(globx, locx, desc_a, info, root) import implicit none diff --git a/base/modules/comm/psb_z_comm_mod.f90 b/base/modules/comm/psb_z_comm_mod.f90 index bb38d7253..58aabba29 100644 --- a/base/modules/comm/psb_z_comm_mod.f90 +++ b/base/modules/comm/psb_z_comm_mod.f90 @@ -115,6 +115,16 @@ module psb_z_comm_mod integer(psb_ipk_), intent(in), optional :: root,dupl logical, intent(in), optional :: keepnum,keeploc end subroutine psb_lzsp_allgather + subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) + import + implicit none + type(psb_lzspmat_type), intent(inout) :: loca + type(psb_lzspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_lzlzsp_allgather subroutine psb_zgather_vect(globx, locx, desc_a, info, root) import implicit none diff --git a/base/modules/serial/psb_c_base_mat_mod.f90 b/base/modules/serial/psb_c_base_mat_mod.f90 index f320bd0e6..521976786 100644 --- a/base/modules/serial/psb_c_base_mat_mod.f90 +++ b/base/modules/serial/psb_c_base_mat_mod.f90 @@ -276,9 +276,20 @@ module psb_c_base_mat_mod procedure, pass(a) :: clone => psb_lc_base_clone procedure, pass(a) :: make_nonunit => psb_lc_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_lc_base_clean_zeros - procedure, pass(a) :: scals => psb_lc_base_scals - procedure, pass(a) :: scalv => psb_lc_base_scal - generic, public :: scal => scals, scalv + + ! + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_lc_base_scals + procedure, pass(a) :: scalv => psb_lc_base_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: maxval => psb_lc_base_maxval + procedure, pass(a) :: spnmi => psb_lc_base_csnmi + procedure, pass(a) :: spnm1 => psb_lc_base_csnm1 + procedure, pass(a) :: rowsum => psb_lc_base_rowsum + procedure, pass(a) :: arwsum => psb_lc_base_arwsum + procedure, pass(a) :: colsum => psb_lc_base_colsum + procedure, pass(a) :: aclsum => psb_lc_base_aclsum ! ! Convert internal indices ! @@ -366,8 +377,19 @@ module psb_c_base_mat_mod procedure, pass(a) :: set_by_cols => lc_coo_set_by_cols procedure, pass(a) :: set_sort_status => lc_coo_set_sort_status procedure, pass(a) :: get_sort_status => lc_coo_get_sort_status - procedure, pass(a) :: scals => psb_lc_coo_scals - procedure, pass(a) :: scalv => psb_lc_coo_scal + + + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_lc_coo_scals + procedure, pass(a) :: scalv => psb_lc_coo_scal + procedure, pass(a) :: maxval => psb_lc_coo_maxval + procedure, pass(a) :: spnmi => psb_lc_coo_csnmi + procedure, pass(a) :: spnm1 => psb_lc_coo_csnm1 + procedure, pass(a) :: rowsum => psb_lc_coo_rowsum + procedure, pass(a) :: arwsum => psb_lc_coo_arwsum + procedure, pass(a) :: colsum => psb_lc_coo_colsum + procedure, pass(a) :: aclsum => psb_lc_coo_aclsum ! ! This is COO specific @@ -2719,7 +2741,83 @@ module psb_c_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_clean_zeros end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_maxval + interface + function psb_lc_coo_maxval(a) result(res) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_coo_maxval + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_csnmi + interface + function psb_lc_coo_csnmi(a) result(res) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_coo_csnmi + end interface + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_csnm1 + interface + function psb_lc_coo_csnm1(a) result(res) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_coo_csnm1 + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_rowsum + interface + subroutine psb_lc_coo_rowsum(d,a) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_coo_rowsum + end interface + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_arwsum + interface + subroutine psb_lc_coo_arwsum(d,a) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_coo_arwsum + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_colsum + interface + subroutine psb_lc_coo_colsum(d,a) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_coo_colsum + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_aclsum + interface + subroutine psb_lc_coo_aclsum(d,a) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_coo_aclsum + end interface + ! !> Function base_scals: !! \memberof psb_lc_base_sparse_mat @@ -2756,6 +2854,110 @@ module psb_c_base_mat_mod end subroutine psb_lc_base_scal end interface + ! + !> Function base_maxval: + !! \memberof psb_lc_base_sparse_mat + !! \brief Maximum absolute value of all coefficients; + !! + ! + interface + function psb_lc_base_maxval(a) result(res) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_base_maxval + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_lc_base_sparse_mat + !! \brief Operator infinity norm + !! + ! + interface + function psb_lc_base_csnmi(a) result(res) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_base_csnmi + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_lc_base_sparse_mat + !! \brief Operator 1-norm + !! + ! + interface + function psb_lc_base_csnm1(a) result(res) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_base_csnm1 + end interface + + ! + ! + !> Function base_rowsum: + !! \memberof psb_lc_base_sparse_mat + !! \brief Sum along the rows + !! \param d(:) The output row sums + !! + ! + interface + subroutine psb_lc_base_rowsum(d,a) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_base_rowsum + end interface + + ! + !> Function base_arwsum: + !! \memberof psb_lc_base_sparse_mat + !! \brief Absolute value sum along the rows + !! \param d(:) The output row sums + !! + interface + subroutine psb_lc_base_arwsum(d,a) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_base_arwsum + end interface + + ! + ! + !> Function base_colsum: + !! \memberof psb_lc_base_sparse_mat + !! \brief Sum along the columns + !! \param d(:) The output col sums + !! + ! + interface + subroutine psb_lc_base_colsum(d,a) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_base_colsum + end interface + + ! + !> Function base_aclsum: + !! \memberof psb_lc_base_sparse_mat + !! \brief Absolute value sum along the columns + !! \param d(:) The output col sums + !! + interface + subroutine psb_lc_base_aclsum(d,a) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_base_aclsum + end interface + ! !> Function transp: diff --git a/base/modules/serial/psb_c_csc_mat_mod.f90 b/base/modules/serial/psb_c_csc_mat_mod.f90 index 0d252220d..6c5cd61f2 100644 --- a/base/modules/serial/psb_c_csc_mat_mod.f90 +++ b/base/modules/serial/psb_c_csc_mat_mod.f90 @@ -126,6 +126,12 @@ module psb_c_csc_mat_mod procedure, pass(a) :: sizeof => lc_csc_sizeof procedure, pass(a) :: scals => psb_lc_csc_scals procedure, pass(a) :: scalv => psb_lc_csc_scal + procedure, pass(a) :: maxval => psb_lc_csc_maxval + procedure, pass(a) :: spnm1 => psb_lc_csc_csnm1 + procedure, pass(a) :: rowsum => psb_lc_csc_rowsum + procedure, pass(a) :: arwsum => psb_lc_csc_arwsum + procedure, pass(a) :: colsum => psb_lc_csc_colsum + procedure, pass(a) :: aclsum => psb_lc_csc_aclsum procedure, pass(a) :: reallocate_nz => psb_lc_csc_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_lc_csc_allocate_mnnz procedure, pass(a) :: cp_to_coo => psb_lc_cp_csc_to_coo @@ -796,6 +802,66 @@ module psb_c_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csc_get_diag end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_maxval + interface + function psb_lc_csc_maxval(a) result(res) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csc_maxval + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_csnm1 + interface + function psb_lc_csc_csnm1(a) result(res) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csc_csnm1 + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_rowsum + interface + subroutine psb_lc_csc_rowsum(d,a) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csc_rowsum + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_arwsum + interface + subroutine psb_lc_csc_arwsum(d,a) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csc_arwsum + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_colsum + interface + subroutine psb_lc_csc_colsum(d,a) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csc_colsum + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_aclsum + interface + subroutine psb_lc_csc_aclsum(d,a) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csc_aclsum + end interface !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_scal diff --git a/base/modules/serial/psb_c_csr_mat_mod.f90 b/base/modules/serial/psb_c_csr_mat_mod.f90 index 30ddaefce..0606c187e 100644 --- a/base/modules/serial/psb_c_csr_mat_mod.f90 +++ b/base/modules/serial/psb_c_csr_mat_mod.f90 @@ -538,6 +538,12 @@ module psb_c_csr_mat_mod procedure, pass(a) :: mold => psb_lc_csr_mold procedure, pass(a) :: scals => psb_lc_csr_scals procedure, pass(a) :: scalv => psb_lc_csr_scal + procedure, pass(a) :: maxval => psb_lc_csr_maxval + procedure, pass(a) :: spnmi => psb_lc_csr_csnmi + procedure, pass(a) :: rowsum => psb_lc_csr_rowsum + procedure, pass(a) :: arwsum => psb_lc_csr_arwsum + procedure, pass(a) :: colsum => psb_lc_csr_colsum + procedure, pass(a) :: aclsum => psb_lc_csr_aclsum end type psb_lc_csr_sparse_mat @@ -821,8 +827,67 @@ module psb_c_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csr_scals end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_maxval + interface + function psb_lc_csr_maxval(a) result(res) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csr_maxval + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_csnmi + interface + function psb_lc_csr_csnmi(a) result(res) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csr_csnmi + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_rowsum + interface + subroutine psb_lc_csr_rowsum(d,a) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csr_rowsum + end interface + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_arwsum + interface + subroutine psb_lc_csr_arwsum(d,a) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csr_arwsum + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_colsum + interface + subroutine psb_lc_csr_colsum(d,a) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csr_colsum + end interface + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_aclsum + interface + subroutine psb_lc_csr_aclsum(d,a) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csr_aclsum + end interface + contains diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 index 664d33fac..e07eb667a 100644 --- a/base/modules/serial/psb_c_mat_mod.F90 +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -388,6 +388,13 @@ module psb_c_mat_mod ! Computational routines procedure, pass(a) :: get_diag => psb_lc_get_diag + procedure, pass(a) :: maxval => psb_lc_maxval + procedure, pass(a) :: spnmi => psb_lc_csnmi + procedure, pass(a) :: spnm1 => psb_lc_csnm1 + procedure, pass(a) :: rowsum => psb_lc_rowsum + procedure, pass(a) :: arwsum => psb_lc_arwsum + procedure, pass(a) :: colsum => psb_lc_colsum + procedure, pass(a) :: aclsum => psb_lc_aclsum procedure, pass(a) :: scals => psb_lc_scals procedure, pass(a) :: scalv => psb_lc_scal generic, public :: scal => scals, scalv @@ -1679,14 +1686,68 @@ module psb_c_mat_mod end subroutine psb_lc_scals end interface + interface + function psb_lc_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_maxval + end interface + + interface + function psb_lc_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csnmi + end interface + + interface + function psb_lc_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csnm1 + end interface + interface + function psb_lc_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_rowsum + end interface + interface + function psb_lc_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_arwsum + end interface + + interface + function psb_lc_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_colsum + end interface + interface + function psb_lc_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_aclsum + end interface contains - - subroutine psb_c_set_mat_default(a) implicit none class(psb_c_base_sparse_mat), intent(in) :: a diff --git a/base/modules/serial/psb_d_base_mat_mod.f90 b/base/modules/serial/psb_d_base_mat_mod.f90 index 81f60c21c..64b20aeea 100644 --- a/base/modules/serial/psb_d_base_mat_mod.f90 +++ b/base/modules/serial/psb_d_base_mat_mod.f90 @@ -276,9 +276,20 @@ module psb_d_base_mat_mod procedure, pass(a) :: clone => psb_ld_base_clone procedure, pass(a) :: make_nonunit => psb_ld_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_ld_base_clean_zeros - procedure, pass(a) :: scals => psb_ld_base_scals - procedure, pass(a) :: scalv => psb_ld_base_scal - generic, public :: scal => scals, scalv + + ! + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_ld_base_scals + procedure, pass(a) :: scalv => psb_ld_base_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: maxval => psb_ld_base_maxval + procedure, pass(a) :: spnmi => psb_ld_base_csnmi + procedure, pass(a) :: spnm1 => psb_ld_base_csnm1 + procedure, pass(a) :: rowsum => psb_ld_base_rowsum + procedure, pass(a) :: arwsum => psb_ld_base_arwsum + procedure, pass(a) :: colsum => psb_ld_base_colsum + procedure, pass(a) :: aclsum => psb_ld_base_aclsum ! ! Convert internal indices ! @@ -366,8 +377,19 @@ module psb_d_base_mat_mod procedure, pass(a) :: set_by_cols => ld_coo_set_by_cols procedure, pass(a) :: set_sort_status => ld_coo_set_sort_status procedure, pass(a) :: get_sort_status => ld_coo_get_sort_status - procedure, pass(a) :: scals => psb_ld_coo_scals - procedure, pass(a) :: scalv => psb_ld_coo_scal + + + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_ld_coo_scals + procedure, pass(a) :: scalv => psb_ld_coo_scal + procedure, pass(a) :: maxval => psb_ld_coo_maxval + procedure, pass(a) :: spnmi => psb_ld_coo_csnmi + procedure, pass(a) :: spnm1 => psb_ld_coo_csnm1 + procedure, pass(a) :: rowsum => psb_ld_coo_rowsum + procedure, pass(a) :: arwsum => psb_ld_coo_arwsum + procedure, pass(a) :: colsum => psb_ld_coo_colsum + procedure, pass(a) :: aclsum => psb_ld_coo_aclsum ! ! This is COO specific @@ -2719,7 +2741,83 @@ module psb_d_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_clean_zeros end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_maxval + interface + function psb_ld_coo_maxval(a) result(res) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_coo_maxval + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_csnmi + interface + function psb_ld_coo_csnmi(a) result(res) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_coo_csnmi + end interface + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_csnm1 + interface + function psb_ld_coo_csnm1(a) result(res) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_coo_csnm1 + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_rowsum + interface + subroutine psb_ld_coo_rowsum(d,a) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_coo_rowsum + end interface + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_arwsum + interface + subroutine psb_ld_coo_arwsum(d,a) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_coo_arwsum + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_colsum + interface + subroutine psb_ld_coo_colsum(d,a) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_coo_colsum + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_aclsum + interface + subroutine psb_ld_coo_aclsum(d,a) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_coo_aclsum + end interface + ! !> Function base_scals: !! \memberof psb_ld_base_sparse_mat @@ -2756,6 +2854,110 @@ module psb_d_base_mat_mod end subroutine psb_ld_base_scal end interface + ! + !> Function base_maxval: + !! \memberof psb_ld_base_sparse_mat + !! \brief Maximum absolute value of all coefficients; + !! + ! + interface + function psb_ld_base_maxval(a) result(res) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_base_maxval + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_ld_base_sparse_mat + !! \brief Operator infinity norm + !! + ! + interface + function psb_ld_base_csnmi(a) result(res) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_base_csnmi + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_ld_base_sparse_mat + !! \brief Operator 1-norm + !! + ! + interface + function psb_ld_base_csnm1(a) result(res) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_base_csnm1 + end interface + + ! + ! + !> Function base_rowsum: + !! \memberof psb_ld_base_sparse_mat + !! \brief Sum along the rows + !! \param d(:) The output row sums + !! + ! + interface + subroutine psb_ld_base_rowsum(d,a) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_base_rowsum + end interface + + ! + !> Function base_arwsum: + !! \memberof psb_ld_base_sparse_mat + !! \brief Absolute value sum along the rows + !! \param d(:) The output row sums + !! + interface + subroutine psb_ld_base_arwsum(d,a) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_base_arwsum + end interface + + ! + ! + !> Function base_colsum: + !! \memberof psb_ld_base_sparse_mat + !! \brief Sum along the columns + !! \param d(:) The output col sums + !! + ! + interface + subroutine psb_ld_base_colsum(d,a) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_base_colsum + end interface + + ! + !> Function base_aclsum: + !! \memberof psb_ld_base_sparse_mat + !! \brief Absolute value sum along the columns + !! \param d(:) The output col sums + !! + interface + subroutine psb_ld_base_aclsum(d,a) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_base_aclsum + end interface + ! !> Function transp: diff --git a/base/modules/serial/psb_d_csc_mat_mod.f90 b/base/modules/serial/psb_d_csc_mat_mod.f90 index fb4a4a482..f494bc3f9 100644 --- a/base/modules/serial/psb_d_csc_mat_mod.f90 +++ b/base/modules/serial/psb_d_csc_mat_mod.f90 @@ -126,6 +126,12 @@ module psb_d_csc_mat_mod procedure, pass(a) :: sizeof => ld_csc_sizeof procedure, pass(a) :: scals => psb_ld_csc_scals procedure, pass(a) :: scalv => psb_ld_csc_scal + procedure, pass(a) :: maxval => psb_ld_csc_maxval + procedure, pass(a) :: spnm1 => psb_ld_csc_csnm1 + procedure, pass(a) :: rowsum => psb_ld_csc_rowsum + procedure, pass(a) :: arwsum => psb_ld_csc_arwsum + procedure, pass(a) :: colsum => psb_ld_csc_colsum + procedure, pass(a) :: aclsum => psb_ld_csc_aclsum procedure, pass(a) :: reallocate_nz => psb_ld_csc_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_ld_csc_allocate_mnnz procedure, pass(a) :: cp_to_coo => psb_ld_cp_csc_to_coo @@ -796,6 +802,66 @@ module psb_d_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csc_get_diag end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_maxval + interface + function psb_ld_csc_maxval(a) result(res) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csc_maxval + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_csnm1 + interface + function psb_ld_csc_csnm1(a) result(res) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csc_csnm1 + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_rowsum + interface + subroutine psb_ld_csc_rowsum(d,a) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csc_rowsum + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_arwsum + interface + subroutine psb_ld_csc_arwsum(d,a) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csc_arwsum + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_colsum + interface + subroutine psb_ld_csc_colsum(d,a) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csc_colsum + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_aclsum + interface + subroutine psb_ld_csc_aclsum(d,a) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csc_aclsum + end interface !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_scal diff --git a/base/modules/serial/psb_d_csr_mat_mod.f90 b/base/modules/serial/psb_d_csr_mat_mod.f90 index 0bb90e0d8..7494bda6a 100644 --- a/base/modules/serial/psb_d_csr_mat_mod.f90 +++ b/base/modules/serial/psb_d_csr_mat_mod.f90 @@ -538,6 +538,12 @@ module psb_d_csr_mat_mod procedure, pass(a) :: mold => psb_ld_csr_mold procedure, pass(a) :: scals => psb_ld_csr_scals procedure, pass(a) :: scalv => psb_ld_csr_scal + procedure, pass(a) :: maxval => psb_ld_csr_maxval + procedure, pass(a) :: spnmi => psb_ld_csr_csnmi + procedure, pass(a) :: rowsum => psb_ld_csr_rowsum + procedure, pass(a) :: arwsum => psb_ld_csr_arwsum + procedure, pass(a) :: colsum => psb_ld_csr_colsum + procedure, pass(a) :: aclsum => psb_ld_csr_aclsum end type psb_ld_csr_sparse_mat @@ -821,8 +827,67 @@ module psb_d_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csr_scals end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_maxval + interface + function psb_ld_csr_maxval(a) result(res) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csr_maxval + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_csnmi + interface + function psb_ld_csr_csnmi(a) result(res) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csr_csnmi + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_rowsum + interface + subroutine psb_ld_csr_rowsum(d,a) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csr_rowsum + end interface + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_arwsum + interface + subroutine psb_ld_csr_arwsum(d,a) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csr_arwsum + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_colsum + interface + subroutine psb_ld_csr_colsum(d,a) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csr_colsum + end interface + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_aclsum + interface + subroutine psb_ld_csr_aclsum(d,a) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csr_aclsum + end interface + contains diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index 4450dc167..bd24197c7 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -388,6 +388,13 @@ module psb_d_mat_mod ! Computational routines procedure, pass(a) :: get_diag => psb_ld_get_diag + procedure, pass(a) :: maxval => psb_ld_maxval + procedure, pass(a) :: spnmi => psb_ld_csnmi + procedure, pass(a) :: spnm1 => psb_ld_csnm1 + procedure, pass(a) :: rowsum => psb_ld_rowsum + procedure, pass(a) :: arwsum => psb_ld_arwsum + procedure, pass(a) :: colsum => psb_ld_colsum + procedure, pass(a) :: aclsum => psb_ld_aclsum procedure, pass(a) :: scals => psb_ld_scals procedure, pass(a) :: scalv => psb_ld_scal generic, public :: scal => scals, scalv @@ -1679,14 +1686,68 @@ module psb_d_mat_mod end subroutine psb_ld_scals end interface + interface + function psb_ld_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_maxval + end interface + + interface + function psb_ld_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csnmi + end interface + + interface + function psb_ld_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csnm1 + end interface + interface + function psb_ld_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_rowsum + end interface + interface + function psb_ld_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_arwsum + end interface + + interface + function psb_ld_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_colsum + end interface + interface + function psb_ld_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_aclsum + end interface contains - - subroutine psb_d_set_mat_default(a) implicit none class(psb_d_base_sparse_mat), intent(in) :: a diff --git a/base/modules/serial/psb_s_base_mat_mod.f90 b/base/modules/serial/psb_s_base_mat_mod.f90 index a04665afa..7762ca9c6 100644 --- a/base/modules/serial/psb_s_base_mat_mod.f90 +++ b/base/modules/serial/psb_s_base_mat_mod.f90 @@ -276,9 +276,20 @@ module psb_s_base_mat_mod procedure, pass(a) :: clone => psb_ls_base_clone procedure, pass(a) :: make_nonunit => psb_ls_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_ls_base_clean_zeros - procedure, pass(a) :: scals => psb_ls_base_scals - procedure, pass(a) :: scalv => psb_ls_base_scal - generic, public :: scal => scals, scalv + + ! + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_ls_base_scals + procedure, pass(a) :: scalv => psb_ls_base_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: maxval => psb_ls_base_maxval + procedure, pass(a) :: spnmi => psb_ls_base_csnmi + procedure, pass(a) :: spnm1 => psb_ls_base_csnm1 + procedure, pass(a) :: rowsum => psb_ls_base_rowsum + procedure, pass(a) :: arwsum => psb_ls_base_arwsum + procedure, pass(a) :: colsum => psb_ls_base_colsum + procedure, pass(a) :: aclsum => psb_ls_base_aclsum ! ! Convert internal indices ! @@ -366,8 +377,19 @@ module psb_s_base_mat_mod procedure, pass(a) :: set_by_cols => ls_coo_set_by_cols procedure, pass(a) :: set_sort_status => ls_coo_set_sort_status procedure, pass(a) :: get_sort_status => ls_coo_get_sort_status - procedure, pass(a) :: scals => psb_ls_coo_scals - procedure, pass(a) :: scalv => psb_ls_coo_scal + + + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_ls_coo_scals + procedure, pass(a) :: scalv => psb_ls_coo_scal + procedure, pass(a) :: maxval => psb_ls_coo_maxval + procedure, pass(a) :: spnmi => psb_ls_coo_csnmi + procedure, pass(a) :: spnm1 => psb_ls_coo_csnm1 + procedure, pass(a) :: rowsum => psb_ls_coo_rowsum + procedure, pass(a) :: arwsum => psb_ls_coo_arwsum + procedure, pass(a) :: colsum => psb_ls_coo_colsum + procedure, pass(a) :: aclsum => psb_ls_coo_aclsum ! ! This is COO specific @@ -2719,7 +2741,83 @@ module psb_s_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_clean_zeros end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_maxval + interface + function psb_ls_coo_maxval(a) result(res) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_coo_maxval + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_csnmi + interface + function psb_ls_coo_csnmi(a) result(res) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_coo_csnmi + end interface + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_csnm1 + interface + function psb_ls_coo_csnm1(a) result(res) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_coo_csnm1 + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_rowsum + interface + subroutine psb_ls_coo_rowsum(d,a) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_coo_rowsum + end interface + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_arwsum + interface + subroutine psb_ls_coo_arwsum(d,a) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_coo_arwsum + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_colsum + interface + subroutine psb_ls_coo_colsum(d,a) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_coo_colsum + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_aclsum + interface + subroutine psb_ls_coo_aclsum(d,a) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_coo_aclsum + end interface + ! !> Function base_scals: !! \memberof psb_ls_base_sparse_mat @@ -2756,6 +2854,110 @@ module psb_s_base_mat_mod end subroutine psb_ls_base_scal end interface + ! + !> Function base_maxval: + !! \memberof psb_ls_base_sparse_mat + !! \brief Maximum absolute value of all coefficients; + !! + ! + interface + function psb_ls_base_maxval(a) result(res) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_base_maxval + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_ls_base_sparse_mat + !! \brief Operator infinity norm + !! + ! + interface + function psb_ls_base_csnmi(a) result(res) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_base_csnmi + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_ls_base_sparse_mat + !! \brief Operator 1-norm + !! + ! + interface + function psb_ls_base_csnm1(a) result(res) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_base_csnm1 + end interface + + ! + ! + !> Function base_rowsum: + !! \memberof psb_ls_base_sparse_mat + !! \brief Sum along the rows + !! \param d(:) The output row sums + !! + ! + interface + subroutine psb_ls_base_rowsum(d,a) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_base_rowsum + end interface + + ! + !> Function base_arwsum: + !! \memberof psb_ls_base_sparse_mat + !! \brief Absolute value sum along the rows + !! \param d(:) The output row sums + !! + interface + subroutine psb_ls_base_arwsum(d,a) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_base_arwsum + end interface + + ! + ! + !> Function base_colsum: + !! \memberof psb_ls_base_sparse_mat + !! \brief Sum along the columns + !! \param d(:) The output col sums + !! + ! + interface + subroutine psb_ls_base_colsum(d,a) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_base_colsum + end interface + + ! + !> Function base_aclsum: + !! \memberof psb_ls_base_sparse_mat + !! \brief Absolute value sum along the columns + !! \param d(:) The output col sums + !! + interface + subroutine psb_ls_base_aclsum(d,a) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_base_aclsum + end interface + ! !> Function transp: diff --git a/base/modules/serial/psb_s_csc_mat_mod.f90 b/base/modules/serial/psb_s_csc_mat_mod.f90 index 129dfeca1..2bf812ec2 100644 --- a/base/modules/serial/psb_s_csc_mat_mod.f90 +++ b/base/modules/serial/psb_s_csc_mat_mod.f90 @@ -126,6 +126,12 @@ module psb_s_csc_mat_mod procedure, pass(a) :: sizeof => ls_csc_sizeof procedure, pass(a) :: scals => psb_ls_csc_scals procedure, pass(a) :: scalv => psb_ls_csc_scal + procedure, pass(a) :: maxval => psb_ls_csc_maxval + procedure, pass(a) :: spnm1 => psb_ls_csc_csnm1 + procedure, pass(a) :: rowsum => psb_ls_csc_rowsum + procedure, pass(a) :: arwsum => psb_ls_csc_arwsum + procedure, pass(a) :: colsum => psb_ls_csc_colsum + procedure, pass(a) :: aclsum => psb_ls_csc_aclsum procedure, pass(a) :: reallocate_nz => psb_ls_csc_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_ls_csc_allocate_mnnz procedure, pass(a) :: cp_to_coo => psb_ls_cp_csc_to_coo @@ -796,6 +802,66 @@ module psb_s_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csc_get_diag end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_maxval + interface + function psb_ls_csc_maxval(a) result(res) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csc_maxval + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_csnm1 + interface + function psb_ls_csc_csnm1(a) result(res) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csc_csnm1 + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_rowsum + interface + subroutine psb_ls_csc_rowsum(d,a) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csc_rowsum + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_arwsum + interface + subroutine psb_ls_csc_arwsum(d,a) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csc_arwsum + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_colsum + interface + subroutine psb_ls_csc_colsum(d,a) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csc_colsum + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_aclsum + interface + subroutine psb_ls_csc_aclsum(d,a) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csc_aclsum + end interface !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_scal diff --git a/base/modules/serial/psb_s_csr_mat_mod.f90 b/base/modules/serial/psb_s_csr_mat_mod.f90 index 696b79330..8d861d7eb 100644 --- a/base/modules/serial/psb_s_csr_mat_mod.f90 +++ b/base/modules/serial/psb_s_csr_mat_mod.f90 @@ -538,6 +538,12 @@ module psb_s_csr_mat_mod procedure, pass(a) :: mold => psb_ls_csr_mold procedure, pass(a) :: scals => psb_ls_csr_scals procedure, pass(a) :: scalv => psb_ls_csr_scal + procedure, pass(a) :: maxval => psb_ls_csr_maxval + procedure, pass(a) :: spnmi => psb_ls_csr_csnmi + procedure, pass(a) :: rowsum => psb_ls_csr_rowsum + procedure, pass(a) :: arwsum => psb_ls_csr_arwsum + procedure, pass(a) :: colsum => psb_ls_csr_colsum + procedure, pass(a) :: aclsum => psb_ls_csr_aclsum end type psb_ls_csr_sparse_mat @@ -821,8 +827,67 @@ module psb_s_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csr_scals end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_maxval + interface + function psb_ls_csr_maxval(a) result(res) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csr_maxval + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_csnmi + interface + function psb_ls_csr_csnmi(a) result(res) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csr_csnmi + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_rowsum + interface + subroutine psb_ls_csr_rowsum(d,a) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csr_rowsum + end interface + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_arwsum + interface + subroutine psb_ls_csr_arwsum(d,a) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csr_arwsum + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_colsum + interface + subroutine psb_ls_csr_colsum(d,a) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csr_colsum + end interface + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_aclsum + interface + subroutine psb_ls_csr_aclsum(d,a) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csr_aclsum + end interface + contains diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 index 979a4a4c9..7e68e8a61 100644 --- a/base/modules/serial/psb_s_mat_mod.F90 +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -388,6 +388,13 @@ module psb_s_mat_mod ! Computational routines procedure, pass(a) :: get_diag => psb_ls_get_diag + procedure, pass(a) :: maxval => psb_ls_maxval + procedure, pass(a) :: spnmi => psb_ls_csnmi + procedure, pass(a) :: spnm1 => psb_ls_csnm1 + procedure, pass(a) :: rowsum => psb_ls_rowsum + procedure, pass(a) :: arwsum => psb_ls_arwsum + procedure, pass(a) :: colsum => psb_ls_colsum + procedure, pass(a) :: aclsum => psb_ls_aclsum procedure, pass(a) :: scals => psb_ls_scals procedure, pass(a) :: scalv => psb_ls_scal generic, public :: scal => scals, scalv @@ -1679,14 +1686,68 @@ module psb_s_mat_mod end subroutine psb_ls_scals end interface + interface + function psb_ls_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_maxval + end interface + + interface + function psb_ls_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csnmi + end interface + + interface + function psb_ls_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csnm1 + end interface + interface + function psb_ls_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_rowsum + end interface + interface + function psb_ls_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_arwsum + end interface + + interface + function psb_ls_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_colsum + end interface + interface + function psb_ls_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_aclsum + end interface contains - - subroutine psb_s_set_mat_default(a) implicit none class(psb_s_base_sparse_mat), intent(in) :: a diff --git a/base/modules/serial/psb_z_base_mat_mod.f90 b/base/modules/serial/psb_z_base_mat_mod.f90 index cba195d2c..b86f8a3c2 100644 --- a/base/modules/serial/psb_z_base_mat_mod.f90 +++ b/base/modules/serial/psb_z_base_mat_mod.f90 @@ -276,9 +276,20 @@ module psb_z_base_mat_mod procedure, pass(a) :: clone => psb_lz_base_clone procedure, pass(a) :: make_nonunit => psb_lz_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_lz_base_clean_zeros - procedure, pass(a) :: scals => psb_lz_base_scals - procedure, pass(a) :: scalv => psb_lz_base_scal - generic, public :: scal => scals, scalv + + ! + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_lz_base_scals + procedure, pass(a) :: scalv => psb_lz_base_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: maxval => psb_lz_base_maxval + procedure, pass(a) :: spnmi => psb_lz_base_csnmi + procedure, pass(a) :: spnm1 => psb_lz_base_csnm1 + procedure, pass(a) :: rowsum => psb_lz_base_rowsum + procedure, pass(a) :: arwsum => psb_lz_base_arwsum + procedure, pass(a) :: colsum => psb_lz_base_colsum + procedure, pass(a) :: aclsum => psb_lz_base_aclsum ! ! Convert internal indices ! @@ -366,8 +377,19 @@ module psb_z_base_mat_mod procedure, pass(a) :: set_by_cols => lz_coo_set_by_cols procedure, pass(a) :: set_sort_status => lz_coo_set_sort_status procedure, pass(a) :: get_sort_status => lz_coo_get_sort_status - procedure, pass(a) :: scals => psb_lz_coo_scals - procedure, pass(a) :: scalv => psb_lz_coo_scal + + + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_lz_coo_scals + procedure, pass(a) :: scalv => psb_lz_coo_scal + procedure, pass(a) :: maxval => psb_lz_coo_maxval + procedure, pass(a) :: spnmi => psb_lz_coo_csnmi + procedure, pass(a) :: spnm1 => psb_lz_coo_csnm1 + procedure, pass(a) :: rowsum => psb_lz_coo_rowsum + procedure, pass(a) :: arwsum => psb_lz_coo_arwsum + procedure, pass(a) :: colsum => psb_lz_coo_colsum + procedure, pass(a) :: aclsum => psb_lz_coo_aclsum ! ! This is COO specific @@ -2719,7 +2741,83 @@ module psb_z_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_clean_zeros end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_maxval + interface + function psb_lz_coo_maxval(a) result(res) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_coo_maxval + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_csnmi + interface + function psb_lz_coo_csnmi(a) result(res) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_coo_csnmi + end interface + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_csnm1 + interface + function psb_lz_coo_csnm1(a) result(res) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_coo_csnm1 + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_rowsum + interface + subroutine psb_lz_coo_rowsum(d,a) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_coo_rowsum + end interface + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_arwsum + interface + subroutine psb_lz_coo_arwsum(d,a) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_coo_arwsum + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_colsum + interface + subroutine psb_lz_coo_colsum(d,a) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_coo_colsum + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_aclsum + interface + subroutine psb_lz_coo_aclsum(d,a) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_coo_aclsum + end interface + ! !> Function base_scals: !! \memberof psb_lz_base_sparse_mat @@ -2756,6 +2854,110 @@ module psb_z_base_mat_mod end subroutine psb_lz_base_scal end interface + ! + !> Function base_maxval: + !! \memberof psb_lz_base_sparse_mat + !! \brief Maximum absolute value of all coefficients; + !! + ! + interface + function psb_lz_base_maxval(a) result(res) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_base_maxval + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_lz_base_sparse_mat + !! \brief Operator infinity norm + !! + ! + interface + function psb_lz_base_csnmi(a) result(res) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_base_csnmi + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_lz_base_sparse_mat + !! \brief Operator 1-norm + !! + ! + interface + function psb_lz_base_csnm1(a) result(res) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_base_csnm1 + end interface + + ! + ! + !> Function base_rowsum: + !! \memberof psb_lz_base_sparse_mat + !! \brief Sum along the rows + !! \param d(:) The output row sums + !! + ! + interface + subroutine psb_lz_base_rowsum(d,a) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_base_rowsum + end interface + + ! + !> Function base_arwsum: + !! \memberof psb_lz_base_sparse_mat + !! \brief Absolute value sum along the rows + !! \param d(:) The output row sums + !! + interface + subroutine psb_lz_base_arwsum(d,a) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_base_arwsum + end interface + + ! + ! + !> Function base_colsum: + !! \memberof psb_lz_base_sparse_mat + !! \brief Sum along the columns + !! \param d(:) The output col sums + !! + ! + interface + subroutine psb_lz_base_colsum(d,a) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_base_colsum + end interface + + ! + !> Function base_aclsum: + !! \memberof psb_lz_base_sparse_mat + !! \brief Absolute value sum along the columns + !! \param d(:) The output col sums + !! + interface + subroutine psb_lz_base_aclsum(d,a) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_base_aclsum + end interface + ! !> Function transp: diff --git a/base/modules/serial/psb_z_csc_mat_mod.f90 b/base/modules/serial/psb_z_csc_mat_mod.f90 index 7c6c9420f..cbbc39489 100644 --- a/base/modules/serial/psb_z_csc_mat_mod.f90 +++ b/base/modules/serial/psb_z_csc_mat_mod.f90 @@ -126,6 +126,12 @@ module psb_z_csc_mat_mod procedure, pass(a) :: sizeof => lz_csc_sizeof procedure, pass(a) :: scals => psb_lz_csc_scals procedure, pass(a) :: scalv => psb_lz_csc_scal + procedure, pass(a) :: maxval => psb_lz_csc_maxval + procedure, pass(a) :: spnm1 => psb_lz_csc_csnm1 + procedure, pass(a) :: rowsum => psb_lz_csc_rowsum + procedure, pass(a) :: arwsum => psb_lz_csc_arwsum + procedure, pass(a) :: colsum => psb_lz_csc_colsum + procedure, pass(a) :: aclsum => psb_lz_csc_aclsum procedure, pass(a) :: reallocate_nz => psb_lz_csc_reallocate_nz procedure, pass(a) :: allocate_mnnz => psb_lz_csc_allocate_mnnz procedure, pass(a) :: cp_to_coo => psb_lz_cp_csc_to_coo @@ -796,6 +802,66 @@ module psb_z_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csc_get_diag end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_maxval + interface + function psb_lz_csc_maxval(a) result(res) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csc_maxval + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_csnm1 + interface + function psb_lz_csc_csnm1(a) result(res) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csc_csnm1 + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_rowsum + interface + subroutine psb_lz_csc_rowsum(d,a) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csc_rowsum + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_arwsum + interface + subroutine psb_lz_csc_arwsum(d,a) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csc_arwsum + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_colsum + interface + subroutine psb_lz_csc_colsum(d,a) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csc_colsum + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_aclsum + interface + subroutine psb_lz_csc_aclsum(d,a) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csc_aclsum + end interface !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_scal diff --git a/base/modules/serial/psb_z_csr_mat_mod.f90 b/base/modules/serial/psb_z_csr_mat_mod.f90 index d54cb9677..df09569a2 100644 --- a/base/modules/serial/psb_z_csr_mat_mod.f90 +++ b/base/modules/serial/psb_z_csr_mat_mod.f90 @@ -538,6 +538,12 @@ module psb_z_csr_mat_mod procedure, pass(a) :: mold => psb_lz_csr_mold procedure, pass(a) :: scals => psb_lz_csr_scals procedure, pass(a) :: scalv => psb_lz_csr_scal + procedure, pass(a) :: maxval => psb_lz_csr_maxval + procedure, pass(a) :: spnmi => psb_lz_csr_csnmi + procedure, pass(a) :: rowsum => psb_lz_csr_rowsum + procedure, pass(a) :: arwsum => psb_lz_csr_arwsum + procedure, pass(a) :: colsum => psb_lz_csr_colsum + procedure, pass(a) :: aclsum => psb_lz_csr_aclsum end type psb_lz_csr_sparse_mat @@ -821,8 +827,67 @@ module psb_z_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csr_scals end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_maxval + interface + function psb_lz_csr_maxval(a) result(res) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csr_maxval + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_csnmi + interface + function psb_lz_csr_csnmi(a) result(res) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csr_csnmi + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_rowsum + interface + subroutine psb_lz_csr_rowsum(d,a) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csr_rowsum + end interface + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_arwsum + interface + subroutine psb_lz_csr_arwsum(d,a) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csr_arwsum + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_colsum + interface + subroutine psb_lz_csr_colsum(d,a) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csr_colsum + end interface + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_aclsum + interface + subroutine psb_lz_csr_aclsum(d,a) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csr_aclsum + end interface + contains diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 index fca0b326e..6fc5bfe26 100644 --- a/base/modules/serial/psb_z_mat_mod.F90 +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -388,6 +388,13 @@ module psb_z_mat_mod ! Computational routines procedure, pass(a) :: get_diag => psb_lz_get_diag + procedure, pass(a) :: maxval => psb_lz_maxval + procedure, pass(a) :: spnmi => psb_lz_csnmi + procedure, pass(a) :: spnm1 => psb_lz_csnm1 + procedure, pass(a) :: rowsum => psb_lz_rowsum + procedure, pass(a) :: arwsum => psb_lz_arwsum + procedure, pass(a) :: colsum => psb_lz_colsum + procedure, pass(a) :: aclsum => psb_lz_aclsum procedure, pass(a) :: scals => psb_lz_scals procedure, pass(a) :: scalv => psb_lz_scal generic, public :: scal => scals, scalv @@ -1679,14 +1686,68 @@ module psb_z_mat_mod end subroutine psb_lz_scals end interface + interface + function psb_lz_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_maxval + end interface + + interface + function psb_lz_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csnmi + end interface + + interface + function psb_lz_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csnm1 + end interface + interface + function psb_lz_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_rowsum + end interface + interface + function psb_lz_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_arwsum + end interface + + interface + function psb_lz_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_colsum + end interface + interface + function psb_lz_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_aclsum + end interface contains - - subroutine psb_z_set_mat_default(a) implicit none class(psb_z_base_sparse_mat), intent(in) :: a diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index 044f8055d..39edf7a70 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -1578,8 +1578,6 @@ subroutine psb_c_base_scal(d,a,info,side) end subroutine psb_c_base_scal - - function psb_c_base_maxval(a) result(res) use psb_error_mod use psb_const_mod @@ -1770,7 +1768,6 @@ subroutine psb_c_base_aclsum(d,a) end subroutine psb_c_base_aclsum - subroutine psb_c_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod @@ -3434,8 +3431,6 @@ subroutine psb_lc_base_scals(d,a,info) end subroutine psb_lc_base_scals - - subroutine psb_lc_base_scal(d,a,info,side) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scal use psb_error_mod @@ -3460,6 +3455,192 @@ subroutine psb_lc_base_scal(d,a,info,side) end subroutine psb_lc_base_scal +function psb_lc_base_maxval(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_maxval + + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + res = szero + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end function psb_lc_base_maxval + +function psb_lc_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csnmi + + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + real(psb_spk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = szero + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%arwsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_base_csnmi + +function psb_lc_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csnm1 + + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + real(psb_spk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = szero + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%aclsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_base_csnm1 + +subroutine psb_lc_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_rowsum + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_rowsum + +subroutine psb_lc_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_arwsum + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_arwsum + +subroutine psb_lc_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_colsum + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_colsum + +subroutine psb_lc_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_aclsum + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_aclsum subroutine psb_lc_base_get_diag(a,d,info) use psb_error_mod diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 index e697e9557..b37c4feee 100644 --- a/base/serial/impl/psb_c_coo_impl.f90 +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -29,7 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - subroutine psb_c_coo_get_diag(a,d,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_get_diag use psb_error_mod @@ -1936,7 +1935,6 @@ subroutine psb_c_coo_aclsum(d,a) end subroutine psb_c_coo_aclsum - ! == ================================== ! ! @@ -4159,7 +4157,6 @@ subroutine psb_lc_coo_get_diag(a,d,info) end subroutine psb_lc_coo_get_diag - subroutine psb_lc_coo_scal(d,a,info,side) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scal use psb_error_mod @@ -4267,6 +4264,324 @@ subroutine psb_lc_coo_scals(d,a,info) end subroutine psb_lc_coo_scals +function psb_lc_coo_maxval(a) result(res) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_maxval + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + character(len=20) :: name='c_coo_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + res = sone + else + res = szero + end if + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if + +end function psb_lc_coo_maxval + +function psb_lc_coo_csnmi(a) result(res) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csnmi + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_coo_csnmi' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + is_unit = a%is_unit() + if (a%is_by_rows()) then + i = 1 + j = i + res = szero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + if (is_unit) then + acc = sone + else + acc = szero + end if + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + if (is_unit) then + vt = sone + else + vt = szero + end if + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_lc_coo_csnmi + + +function psb_lc_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csnm1 + + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_coo_csnm1' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + if (a%is_unit()) then + vt = sone + else + vt = szero + end if + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_lc_coo_csnm1 + +subroutine psb_lc_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_rowsum + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = cone + else + d = czero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_rowsum + +subroutine psb_lc_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_arwsum + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_arwsum + +subroutine psb_lc_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_colsum + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + if (a%is_unit()) then + d = cone + else + d = czero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_colsum + +subroutine psb_lc_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_aclsum + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_aclsum + subroutine psb_lc_coo_reallocate_nz(nz,a) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_reallocate_nz use psb_error_mod diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index eec90397c..549fd98eb 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -3116,6 +3116,279 @@ subroutine psb_lc_csc_scals(d,a,info) end subroutine psb_lc_csc_scals +function psb_lc_csc_maxval(a) result(res) + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_maxval + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: nnz + character(len=20) :: name='lc_csc_maxval' + logical, parameter :: debug=.false. + + + if (a%is_unit()) then + res = sone + else + res = szero + end if + if (a%is_dev()) call a%sync() + + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_lc_csc_maxval + +function psb_lc_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csnm1 + + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_csc_csnm1' + logical, parameter :: debug=.false. + + + res = szero + if (a%is_dev()) call a%sync() + m = a%get_nrows() + n = a%get_ncols() + is_unit = a%is_unit() + do j=1, n + if (is_unit) then + acc = sone + else + acc = szero + end if + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_lc_csc_csnm1 + +subroutine psb_lc_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_colsum + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = cone + else + d(i) = czero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_colsum + +subroutine psb_lc_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_aclsum + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_lpk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = sone + else + d(i) = szero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, a%get_ncols() + d(i) = d(i) + sone + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_aclsum + +subroutine psb_lc_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_rowsum + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = cone + else + d = czero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_rowsum + +subroutine psb_lc_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_arwsum + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_arwsum + + ! == =================================== ! ! diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index 92ffa2213..931613adf 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -1302,7 +1302,7 @@ function psb_c_csr_csnmi(a) result(res) if (a%is_dev()) call a%sync() do i = 1, a%get_nrows() - acc = dzero + acc = szero do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do @@ -3333,6 +3333,261 @@ subroutine psb_lc_csr_scals(d,a,info) end subroutine psb_lc_csr_scals +function psb_lc_csr_maxval(a) result(res) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_maxval + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: nnz + integer(psb_ipk_) :: info + character(len=20) :: name='lc_csr_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_lc_csr_maxval + +function psb_lc_csr_csnmi(a) result(res) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csnmi + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nr, ir, jc, nc + real(psb_spk_) :: acc + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_csnmi' + logical, parameter :: debug=.false. + + + res = szero + if (a%is_dev()) call a%sync() + + do i = 1, a%get_nrows() + acc = szero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_lc_csr_csnmi + +subroutine psb_lc_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_rowsum + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = czero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + cone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_rowsum + +subroutine psb_lc_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_arwsum + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = szero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + sone + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_arwsum + +subroutine psb_lc_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_colsum + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = czero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + cone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_colsum + +subroutine psb_lc_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_aclsum + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = szero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + sone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_aclsum ! == =================================== diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index c13a88ae9..f3c5040f3 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -4480,6 +4480,233 @@ subroutine psb_lc_scals(d,a,info) end subroutine psb_lc_scals +function psb_lc_maxval(a) result(res) + use psb_c_mat_mod, psb_protect_name => psb_lc_maxval + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%maxval() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_maxval + +function psb_lc_csnmi(a) result(res) + use psb_c_mat_mod, psb_protect_name => psb_lc_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnmi() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_csnmi + +function psb_lc_csnm1(a) result(res) + use psb_c_mat_mod, psb_protect_name => psb_lc_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnm1() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_csnm1 + + +function psb_lc_rowsum(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + call a%a%rowsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_rowsum + +function psb_lc_arwsum(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%arwsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_arwsum + +function psb_lc_colsum(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%colsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_colsum + +function psb_lc_aclsum(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%aclsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_aclsum + subroutine psb_lc_mv_from_ib(a,b) use psb_error_mod use psb_const_mod diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index b54808507..dc0fe044e 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -1578,8 +1578,6 @@ subroutine psb_d_base_scal(d,a,info,side) end subroutine psb_d_base_scal - - function psb_d_base_maxval(a) result(res) use psb_error_mod use psb_const_mod @@ -1770,7 +1768,6 @@ subroutine psb_d_base_aclsum(d,a) end subroutine psb_d_base_aclsum - subroutine psb_d_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod @@ -3434,8 +3431,6 @@ subroutine psb_ld_base_scals(d,a,info) end subroutine psb_ld_base_scals - - subroutine psb_ld_base_scal(d,a,info,side) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scal use psb_error_mod @@ -3460,6 +3455,192 @@ subroutine psb_ld_base_scal(d,a,info,side) end subroutine psb_ld_base_scal +function psb_ld_base_maxval(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_maxval + + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + res = dzero + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end function psb_ld_base_maxval + +function psb_ld_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csnmi + + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + real(psb_dpk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = dzero + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%arwsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_base_csnmi + +function psb_ld_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csnm1 + + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + real(psb_dpk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = dzero + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%aclsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_base_csnm1 + +subroutine psb_ld_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_rowsum + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_rowsum + +subroutine psb_ld_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_arwsum + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_arwsum + +subroutine psb_ld_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_colsum + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_colsum + +subroutine psb_ld_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_aclsum + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_aclsum subroutine psb_ld_base_get_diag(a,d,info) use psb_error_mod diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 index 93e4f594d..860eaebc2 100644 --- a/base/serial/impl/psb_d_coo_impl.f90 +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -29,7 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - subroutine psb_d_coo_get_diag(a,d,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_get_diag use psb_error_mod @@ -1936,7 +1935,6 @@ subroutine psb_d_coo_aclsum(d,a) end subroutine psb_d_coo_aclsum - ! == ================================== ! ! @@ -4159,7 +4157,6 @@ subroutine psb_ld_coo_get_diag(a,d,info) end subroutine psb_ld_coo_get_diag - subroutine psb_ld_coo_scal(d,a,info,side) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scal use psb_error_mod @@ -4267,6 +4264,324 @@ subroutine psb_ld_coo_scals(d,a,info) end subroutine psb_ld_coo_scals +function psb_ld_coo_maxval(a) result(res) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_maxval + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + character(len=20) :: name='d_coo_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + res = done + else + res = dzero + end if + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if + +end function psb_ld_coo_maxval + +function psb_ld_coo_csnmi(a) result(res) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csnmi + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_coo_csnmi' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + is_unit = a%is_unit() + if (a%is_by_rows()) then + i = 1 + j = i + res = dzero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + if (is_unit) then + acc = done + else + acc = dzero + end if + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + if (is_unit) then + vt = done + else + vt = dzero + end if + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_ld_coo_csnmi + + +function psb_ld_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csnm1 + + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_coo_csnm1' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + if (a%is_unit()) then + vt = done + else + vt = dzero + end if + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_ld_coo_csnm1 + +subroutine psb_ld_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_rowsum + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_rowsum + +subroutine psb_ld_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_arwsum + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_arwsum + +subroutine psb_ld_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_colsum + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_colsum + +subroutine psb_ld_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_aclsum + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_aclsum + subroutine psb_ld_coo_reallocate_nz(nz,a) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_reallocate_nz use psb_error_mod diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index 5edebb2d5..72c1314d0 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -3116,6 +3116,279 @@ subroutine psb_ld_csc_scals(d,a,info) end subroutine psb_ld_csc_scals +function psb_ld_csc_maxval(a) result(res) + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_maxval + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: nnz + character(len=20) :: name='ld_csc_maxval' + logical, parameter :: debug=.false. + + + if (a%is_unit()) then + res = done + else + res = dzero + end if + if (a%is_dev()) call a%sync() + + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_ld_csc_maxval + +function psb_ld_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csnm1 + + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_csc_csnm1' + logical, parameter :: debug=.false. + + + res = dzero + if (a%is_dev()) call a%sync() + m = a%get_nrows() + n = a%get_ncols() + is_unit = a%is_unit() + do j=1, n + if (is_unit) then + acc = done + else + acc = dzero + end if + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_ld_csc_csnm1 + +subroutine psb_ld_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_colsum + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = done + else + d(i) = dzero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_colsum + +subroutine psb_ld_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_aclsum + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_lpk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = done + else + d(i) = dzero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, a%get_ncols() + d(i) = d(i) + done + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_aclsum + +subroutine psb_ld_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_rowsum + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_rowsum + +subroutine psb_ld_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_arwsum + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_arwsum + + ! == =================================== ! ! diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index 2b3dcb262..22aab0d25 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -3333,6 +3333,261 @@ subroutine psb_ld_csr_scals(d,a,info) end subroutine psb_ld_csr_scals +function psb_ld_csr_maxval(a) result(res) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_maxval + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: nnz + integer(psb_ipk_) :: info + character(len=20) :: name='ld_csr_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_ld_csr_maxval + +function psb_ld_csr_csnmi(a) result(res) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csnmi + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nr, ir, jc, nc + real(psb_dpk_) :: acc + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + if (a%is_dev()) call a%sync() + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_ld_csr_csnmi + +subroutine psb_ld_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_rowsum + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + done + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_rowsum + +subroutine psb_ld_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_arwsum + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + done + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_arwsum + +subroutine psb_ld_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_colsum + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + done + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_colsum + +subroutine psb_ld_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_aclsum + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + done + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_aclsum ! == =================================== diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index d947874b7..0a2591158 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -4480,6 +4480,233 @@ subroutine psb_ld_scals(d,a,info) end subroutine psb_ld_scals +function psb_ld_maxval(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_ld_maxval + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%maxval() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_maxval + +function psb_ld_csnmi(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_ld_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnmi() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_csnmi + +function psb_ld_csnm1(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_ld_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnm1() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_csnm1 + + +function psb_ld_rowsum(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + call a%a%rowsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_rowsum + +function psb_ld_arwsum(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%arwsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_arwsum + +function psb_ld_colsum(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%colsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_colsum + +function psb_ld_aclsum(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%aclsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_aclsum + subroutine psb_ld_mv_from_ib(a,b) use psb_error_mod use psb_const_mod diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index 7cc0237b0..51be627e0 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -1578,8 +1578,6 @@ subroutine psb_s_base_scal(d,a,info,side) end subroutine psb_s_base_scal - - function psb_s_base_maxval(a) result(res) use psb_error_mod use psb_const_mod @@ -1770,7 +1768,6 @@ subroutine psb_s_base_aclsum(d,a) end subroutine psb_s_base_aclsum - subroutine psb_s_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod @@ -3434,8 +3431,6 @@ subroutine psb_ls_base_scals(d,a,info) end subroutine psb_ls_base_scals - - subroutine psb_ls_base_scal(d,a,info,side) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scal use psb_error_mod @@ -3460,6 +3455,192 @@ subroutine psb_ls_base_scal(d,a,info,side) end subroutine psb_ls_base_scal +function psb_ls_base_maxval(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_maxval + + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + res = szero + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end function psb_ls_base_maxval + +function psb_ls_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csnmi + + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + real(psb_spk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = szero + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%arwsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_base_csnmi + +function psb_ls_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csnm1 + + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + real(psb_spk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = szero + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%aclsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_base_csnm1 + +subroutine psb_ls_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_rowsum + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_rowsum + +subroutine psb_ls_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_arwsum + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_arwsum + +subroutine psb_ls_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_colsum + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_colsum + +subroutine psb_ls_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_aclsum + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_aclsum subroutine psb_ls_base_get_diag(a,d,info) use psb_error_mod diff --git a/base/serial/impl/psb_s_coo_impl.f90 b/base/serial/impl/psb_s_coo_impl.f90 index 8c7f50285..6063cb324 100644 --- a/base/serial/impl/psb_s_coo_impl.f90 +++ b/base/serial/impl/psb_s_coo_impl.f90 @@ -29,7 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - subroutine psb_s_coo_get_diag(a,d,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_get_diag use psb_error_mod @@ -1936,7 +1935,6 @@ subroutine psb_s_coo_aclsum(d,a) end subroutine psb_s_coo_aclsum - ! == ================================== ! ! @@ -4159,7 +4157,6 @@ subroutine psb_ls_coo_get_diag(a,d,info) end subroutine psb_ls_coo_get_diag - subroutine psb_ls_coo_scal(d,a,info,side) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scal use psb_error_mod @@ -4267,6 +4264,324 @@ subroutine psb_ls_coo_scals(d,a,info) end subroutine psb_ls_coo_scals +function psb_ls_coo_maxval(a) result(res) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_maxval + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + character(len=20) :: name='s_coo_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + res = sone + else + res = szero + end if + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if + +end function psb_ls_coo_maxval + +function psb_ls_coo_csnmi(a) result(res) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csnmi + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_coo_csnmi' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + is_unit = a%is_unit() + if (a%is_by_rows()) then + i = 1 + j = i + res = szero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + if (is_unit) then + acc = sone + else + acc = szero + end if + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + if (is_unit) then + vt = sone + else + vt = szero + end if + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_ls_coo_csnmi + + +function psb_ls_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csnm1 + + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_coo_csnm1' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + if (a%is_unit()) then + vt = sone + else + vt = szero + end if + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_ls_coo_csnm1 + +subroutine psb_ls_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_rowsum + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_rowsum + +subroutine psb_ls_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_arwsum + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_arwsum + +subroutine psb_ls_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_colsum + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_colsum + +subroutine psb_ls_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_aclsum + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_aclsum + subroutine psb_ls_coo_reallocate_nz(nz,a) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_reallocate_nz use psb_error_mod diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index 8e6e11a22..61d4ac05b 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -3116,6 +3116,279 @@ subroutine psb_ls_csc_scals(d,a,info) end subroutine psb_ls_csc_scals +function psb_ls_csc_maxval(a) result(res) + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_maxval + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: nnz + character(len=20) :: name='ls_csc_maxval' + logical, parameter :: debug=.false. + + + if (a%is_unit()) then + res = sone + else + res = szero + end if + if (a%is_dev()) call a%sync() + + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_ls_csc_maxval + +function psb_ls_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csnm1 + + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_csc_csnm1' + logical, parameter :: debug=.false. + + + res = szero + if (a%is_dev()) call a%sync() + m = a%get_nrows() + n = a%get_ncols() + is_unit = a%is_unit() + do j=1, n + if (is_unit) then + acc = sone + else + acc = szero + end if + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_ls_csc_csnm1 + +subroutine psb_ls_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_colsum + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = sone + else + d(i) = szero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_colsum + +subroutine psb_ls_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_aclsum + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_lpk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = sone + else + d(i) = szero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, a%get_ncols() + d(i) = d(i) + sone + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_aclsum + +subroutine psb_ls_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_rowsum + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_rowsum + +subroutine psb_ls_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_arwsum + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_arwsum + + ! == =================================== ! ! diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index 0c5d6134b..549ba75c9 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -1302,7 +1302,7 @@ function psb_s_csr_csnmi(a) result(res) if (a%is_dev()) call a%sync() do i = 1, a%get_nrows() - acc = dzero + acc = szero do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do @@ -3333,6 +3333,261 @@ subroutine psb_ls_csr_scals(d,a,info) end subroutine psb_ls_csr_scals +function psb_ls_csr_maxval(a) result(res) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_maxval + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: nnz + integer(psb_ipk_) :: info + character(len=20) :: name='ls_csr_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_ls_csr_maxval + +function psb_ls_csr_csnmi(a) result(res) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csnmi + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nr, ir, jc, nc + real(psb_spk_) :: acc + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_csnmi' + logical, parameter :: debug=.false. + + + res = szero + if (a%is_dev()) call a%sync() + + do i = 1, a%get_nrows() + acc = szero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_ls_csr_csnmi + +subroutine psb_ls_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_rowsum + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = szero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + sone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_rowsum + +subroutine psb_ls_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_arwsum + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = szero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + sone + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_arwsum + +subroutine psb_ls_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_colsum + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = szero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + sone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_colsum + +subroutine psb_ls_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_aclsum + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = szero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + sone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_aclsum ! == =================================== diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index 7739723c6..5977e991c 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -4480,6 +4480,233 @@ subroutine psb_ls_scals(d,a,info) end subroutine psb_ls_scals +function psb_ls_maxval(a) result(res) + use psb_s_mat_mod, psb_protect_name => psb_ls_maxval + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%maxval() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_maxval + +function psb_ls_csnmi(a) result(res) + use psb_s_mat_mod, psb_protect_name => psb_ls_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnmi() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_csnmi + +function psb_ls_csnm1(a) result(res) + use psb_s_mat_mod, psb_protect_name => psb_ls_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnm1() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_csnm1 + + +function psb_ls_rowsum(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + call a%a%rowsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_rowsum + +function psb_ls_arwsum(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%arwsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_arwsum + +function psb_ls_colsum(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%colsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_colsum + +function psb_ls_aclsum(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%aclsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_aclsum + subroutine psb_ls_mv_from_ib(a,b) use psb_error_mod use psb_const_mod diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index 765ff0db7..9dea7fb2f 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -1578,8 +1578,6 @@ subroutine psb_z_base_scal(d,a,info,side) end subroutine psb_z_base_scal - - function psb_z_base_maxval(a) result(res) use psb_error_mod use psb_const_mod @@ -1770,7 +1768,6 @@ subroutine psb_z_base_aclsum(d,a) end subroutine psb_z_base_aclsum - subroutine psb_z_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod @@ -3434,8 +3431,6 @@ subroutine psb_lz_base_scals(d,a,info) end subroutine psb_lz_base_scals - - subroutine psb_lz_base_scal(d,a,info,side) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scal use psb_error_mod @@ -3460,6 +3455,192 @@ subroutine psb_lz_base_scal(d,a,info,side) end subroutine psb_lz_base_scal +function psb_lz_base_maxval(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_maxval + + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + res = dzero + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end function psb_lz_base_maxval + +function psb_lz_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csnmi + + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + real(psb_dpk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = dzero + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%arwsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_base_csnmi + +function psb_lz_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csnm1 + + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + real(psb_dpk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = dzero + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%aclsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_base_csnm1 + +subroutine psb_lz_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_rowsum + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_rowsum + +subroutine psb_lz_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_arwsum + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_arwsum + +subroutine psb_lz_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_colsum + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_colsum + +subroutine psb_lz_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_aclsum + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_aclsum subroutine psb_lz_base_get_diag(a,d,info) use psb_error_mod diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 index cad045405..9b4d74a95 100644 --- a/base/serial/impl/psb_z_coo_impl.f90 +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -29,7 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - subroutine psb_z_coo_get_diag(a,d,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_get_diag use psb_error_mod @@ -1936,7 +1935,6 @@ subroutine psb_z_coo_aclsum(d,a) end subroutine psb_z_coo_aclsum - ! == ================================== ! ! @@ -4159,7 +4157,6 @@ subroutine psb_lz_coo_get_diag(a,d,info) end subroutine psb_lz_coo_get_diag - subroutine psb_lz_coo_scal(d,a,info,side) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scal use psb_error_mod @@ -4267,6 +4264,324 @@ subroutine psb_lz_coo_scals(d,a,info) end subroutine psb_lz_coo_scals +function psb_lz_coo_maxval(a) result(res) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_maxval + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + character(len=20) :: name='z_coo_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + res = done + else + res = dzero + end if + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if + +end function psb_lz_coo_maxval + +function psb_lz_coo_csnmi(a) result(res) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csnmi + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_coo_csnmi' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + is_unit = a%is_unit() + if (a%is_by_rows()) then + i = 1 + j = i + res = dzero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + if (is_unit) then + acc = done + else + acc = dzero + end if + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + if (is_unit) then + vt = done + else + vt = dzero + end if + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_lz_coo_csnmi + + +function psb_lz_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csnm1 + + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_coo_csnm1' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + if (a%is_unit()) then + vt = done + else + vt = dzero + end if + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_lz_coo_csnm1 + +subroutine psb_lz_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_rowsum + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = zone + else + d = zzero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_rowsum + +subroutine psb_lz_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_arwsum + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_arwsum + +subroutine psb_lz_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_colsum + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + if (a%is_unit()) then + d = zone + else + d = zzero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_colsum + +subroutine psb_lz_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_aclsum + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_aclsum + subroutine psb_lz_coo_reallocate_nz(nz,a) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_reallocate_nz use psb_error_mod diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index 8f874e935..399f7808b 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -3116,6 +3116,279 @@ subroutine psb_lz_csc_scals(d,a,info) end subroutine psb_lz_csc_scals +function psb_lz_csc_maxval(a) result(res) + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_maxval + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: nnz + character(len=20) :: name='lz_csc_maxval' + logical, parameter :: debug=.false. + + + if (a%is_unit()) then + res = done + else + res = dzero + end if + if (a%is_dev()) call a%sync() + + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_lz_csc_maxval + +function psb_lz_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csnm1 + + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_csc_csnm1' + logical, parameter :: debug=.false. + + + res = dzero + if (a%is_dev()) call a%sync() + m = a%get_nrows() + n = a%get_ncols() + is_unit = a%is_unit() + do j=1, n + if (is_unit) then + acc = done + else + acc = dzero + end if + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_lz_csc_csnm1 + +subroutine psb_lz_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_colsum + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = zone + else + d(i) = zzero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_colsum + +subroutine psb_lz_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_aclsum + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_lpk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = done + else + d(i) = dzero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, a%get_ncols() + d(i) = d(i) + done + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_aclsum + +subroutine psb_lz_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_rowsum + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = zone + else + d = zzero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_rowsum + +subroutine psb_lz_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_arwsum + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_arwsum + + ! == =================================== ! ! diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index 3c8335b23..4de063e4d 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -3333,6 +3333,261 @@ subroutine psb_lz_csr_scals(d,a,info) end subroutine psb_lz_csr_scals +function psb_lz_csr_maxval(a) result(res) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_maxval + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: nnz + integer(psb_ipk_) :: info + character(len=20) :: name='lz_csr_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_lz_csr_maxval + +function psb_lz_csr_csnmi(a) result(res) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csnmi + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nr, ir, jc, nc + real(psb_dpk_) :: acc + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + if (a%is_dev()) call a%sync() + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_lz_csr_csnmi + +subroutine psb_lz_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_rowsum + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = zzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + zone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_rowsum + +subroutine psb_lz_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_arwsum + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + done + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_arwsum + +subroutine psb_lz_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_colsum + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = zzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + zone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_colsum + +subroutine psb_lz_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_aclsum + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + done + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_aclsum ! == =================================== diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index db0080931..7f5dcc7fa 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -4480,6 +4480,233 @@ subroutine psb_lz_scals(d,a,info) end subroutine psb_lz_scals +function psb_lz_maxval(a) result(res) + use psb_z_mat_mod, psb_protect_name => psb_lz_maxval + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%maxval() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_maxval + +function psb_lz_csnmi(a) result(res) + use psb_z_mat_mod, psb_protect_name => psb_lz_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnmi() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_csnmi + +function psb_lz_csnm1(a) result(res) + use psb_z_mat_mod, psb_protect_name => psb_lz_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnm1() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_csnm1 + + +function psb_lz_rowsum(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + call a%a%rowsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_rowsum + +function psb_lz_arwsum(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%arwsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_arwsum + +function psb_lz_colsum(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%colsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_colsum + +function psb_lz_aclsum(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%aclsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_aclsum + subroutine psb_lz_mv_from_ib(a,b) use psb_error_mod use psb_const_mod