From 49e99a3e82a49d78726bc0b82eda0e07b5eb80db Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 22 Dec 2023 12:01:41 +0100 Subject: [PATCH] Fix conversion and product to enable overlap with GPU --- base/psblas/psb_dspmm.f90 | 1 + base/serial/impl/psb_d_mat_impl.F90 | 313 ++++++++++++++++++++-------- 2 files changed, 231 insertions(+), 83 deletions(-) diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index 780b4d24..8e48c4c2 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -199,6 +199,7 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& block logical, parameter :: do_timings=.true. real(psb_dpk_) :: t1, t2, t3, t4, t5 + !write(0,*) 'Going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt() if (do_timings) call psb_barrier(ctxt) if (do_timings) call psb_tic(mv_phase1) if (doswap_) call psi_swapdata(psb_swap_send_,& diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index 2a6fb9a5..caf725d1 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -1246,54 +1246,66 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_d_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_d_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_d_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) +!!$ if (present(mold)) then +!!$ +!!$ allocate(altmp, mold=mold,stat=info) +!!$ +!!$ else if (present(type)) then +!!$ +!!$ select case (psb_toupper(type)) +!!$ case ('CSR') +!!$ allocate(psb_d_csr_sparse_mat :: altmp, stat=info) +!!$ case ('COO') +!!$ allocate(psb_d_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_d_csc_sparse_mat :: altmp, stat=info) +!!$ case default +!!$ info = psb_err_format_unknown_ +!!$ call psb_errpush(info,name,a_err=type) +!!$ goto 9999 +!!$ end select +!!$ else +!!$ allocate(altmp, mold=psb_get_mat_default(a),stat=info) +!!$ end if +!!$ +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if +!!$ +!!$ +!!$ if (present(dupl)) then +!!$ call altmp%set_dupl(dupl) +!!$ else if (a%is_bld()) then +!!$ ! Does this make sense at all?? Who knows.. +!!$ call altmp%set_dupl(psb_dupl_def_) +!!$ end if +!!$ +!!$ if (debug) write(psb_err_unit,*) 'Converting from ',& +!!$ & a%get_fmt(),' to ',altmp%get_fmt() +!!$ +!!$ call altmp%cp_from_fmt(a%a, info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info = psb_err_from_subroutine_ +!!$ call psb_errpush(info,name,a_err="mv_from") +!!$ goto 9999 +!!$ end if +!!$ +!!$ call move_alloc(altmp,b%a) + call inner_cp_alloc(a%a,b%a,info,type,mold) + if (info /= 0) goto 9999 + if (allocated(a%ad)) then + call inner_cp_alloc(a%ad,b%ad,info,type,mold) + if (info /= 0) goto 9999 end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - - if (present(dupl)) then - call altmp%set_dupl(dupl) - else if (a%is_bld()) then - ! Does this make sense at all?? Who knows.. - call altmp%set_dupl(psb_dupl_def_) + if (allocated(a%and)) then + call inner_cp_alloc(a%and,b%and,info,type,mold) + if (info /= 0) goto 9999 end if - if (debug) write(psb_err_unit,*) 'Converting from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%cp_from_fmt(a%a, info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - call move_alloc(altmp,b%a) call b%trim() call b%set_asb() call psb_erractionrestore(err_act) @@ -1303,6 +1315,69 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) 9999 call psb_error_handler(err_act) return +contains + subroutine inner_cp_alloc(a,b,info,type,mold) + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + + class(psb_d_base_sparse_mat), allocatable :: altmp + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_d_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_d_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else +!!$ allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + end subroutine inner_cp_alloc end subroutine psb_d_cscnv @@ -1345,46 +1420,57 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) goto 9999 end if - if (present(mold)) then - - allocate(altmp, mold=mold,stat=info) - - else if (present(type)) then - - select case (psb_toupper(type)) - case ('CSR') - allocate(psb_d_csr_sparse_mat :: altmp, stat=info) - case ('COO') - allocate(psb_d_coo_sparse_mat :: altmp, stat=info) - case ('CSC') - allocate(psb_d_csc_sparse_mat :: altmp, stat=info) - case default - info = psb_err_format_unknown_ - call psb_errpush(info,name,a_err=type) - goto 9999 - end select - else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) +!!$ if (present(mold)) then +!!$ +!!$ allocate(altmp, mold=mold,stat=info) +!!$ +!!$ else if (present(type)) then +!!$ +!!$ select case (psb_toupper(type)) +!!$ case ('CSR') +!!$ allocate(psb_d_csr_sparse_mat :: altmp, stat=info) +!!$ case ('COO') +!!$ allocate(psb_d_coo_sparse_mat :: altmp, stat=info) +!!$ case ('CSC') +!!$ allocate(psb_d_csc_sparse_mat :: altmp, stat=info) +!!$ case default +!!$ info = psb_err_format_unknown_ +!!$ call psb_errpush(info,name,a_err=type) +!!$ goto 9999 +!!$ end select +!!$ else +!!$ allocate(altmp, mold=psb_get_mat_default(a),stat=info) +!!$ end if +!!$ +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if +!!$ +!!$ if (debug) write(psb_err_unit,*) 'Converting in-place from ',& +!!$ & a%get_fmt(),' to ',altmp%get_fmt() +!!$ +!!$ call altmp%mv_from_fmt(a%a, info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info = psb_err_from_subroutine_ +!!$ call psb_errpush(info,name,a_err="mv_from") +!!$ goto 9999 +!!$ end if +!!$ +!!$ call move_alloc(altmp,a%a) + + call inner_mv_alloc(a%a,info,type,mold) + if (info /= 0) goto 9999 + if (allocated(a%ad)) then + call inner_mv_alloc(a%ad,info,type,mold) + if (info /= 0) goto 9999 end if - - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 + if (allocated(a%and)) then + call inner_mv_alloc(a%and,info,type,mold) + if (info /= 0) goto 9999 end if - - if (debug) write(psb_err_unit,*) 'Converting in-place from ',& - & a%get_fmt(),' to ',altmp%get_fmt() - - call altmp%mv_from_fmt(a%a, info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err="mv_from") - goto 9999 - end if - - call move_alloc(altmp,a%a) call a%trim() call a%set_asb() call psb_erractionrestore(err_act) @@ -1394,7 +1480,68 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) 9999 call psb_error_handler(err_act) return - +contains + subroutine inner_mv_alloc(a,info,type,mold) + class(psb_d_base_sparse_mat), intent(inout), allocatable :: a + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + + class(psb_d_base_sparse_mat), allocatable :: altmp + + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_d_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_d_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else +!!$ allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + end subroutine inner_mv_alloc end subroutine psb_d_cscnv_ip