From b3f3b20179d2da5831baf209497f8238fe162b13 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 12 Jun 2020 14:27:49 +0200 Subject: [PATCH] Further improvements to mat_bld/mat_asb --- .../mld_d_dec_aggregator_mat_asb.f90 | 190 ++---- .../impl/aggregator/mld_d_spmm_bld_inner.f90 | 562 ++++++------------ .../aggregator/mld_daggrmat_nosmth_bld.f90 | 1 - 3 files changed, 218 insertions(+), 535 deletions(-) diff --git a/mlprec/impl/aggregator/mld_d_dec_aggregator_mat_asb.f90 b/mlprec/impl/aggregator/mld_d_dec_aggregator_mat_asb.f90 index 6e00f74c..1ce3417d 100644 --- a/mlprec/impl/aggregator/mld_d_dec_aggregator_mat_asb.f90 +++ b/mlprec/impl/aggregator/mld_d_dec_aggregator_mat_asb.f90 @@ -119,150 +119,54 @@ subroutine mld_d_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,& ntaggr = sum(nlaggr) - if (.false.) then - select case(parms%coarse_mat) + select case(parms%coarse_mat) + + case(mld_distr_mat_) + + call ac%cscnv(info,type='csr') + call op_prol%cscnv(info,type='csr') + call op_restr%cscnv(info,type='csr') + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call op_prol%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') + call op_prol%mv_from(tmpcoo) + + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') + call op_restr%mv_from(tmpcoo) + + call op_prol%set_ncols(ntaggr) + call op_restr%set_nrows(ntaggr) + + call ac%mv_to(tmpcoo) + call tmp_ac%mv_from(tmpcoo) + call psb_gather(ac,tmp_ac,desc_ac,info,root=-ione,dupl=psb_dupl_add_,keeploc=.false.) + + call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(desc_ac,info) + ! + ! Now that we have the descriptors and the restrictor, we should + ! update the W. But we don't, because REPL is only valid + ! at the coarsest level, so no need to carry over. + ! + + if (info /= psb_success_) goto 9999 + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + goto 9999 + end select - case(mld_distr_mat_) - - call ac%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - i_nl = nlaggr(me+1) - if (info == psb_success_) call psb_cdall(ictxt,desc_ac,info,nl=i_nl) - if (info == psb_success_) call psb_cdins(nzl,tmpcoo%ia,tmpcoo%ja,desc_ac,info) - if (info == psb_success_) call psb_cdasb(desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ja(1:nzl),desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating desc_ac and converting ac') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Assembld aux descr. distr.' - call ac%mv_from(tmpcoo) - call ac%set_nrows(desc_ac%get_local_rows()) - call ac%set_ncols(desc_ac%get_local_cols()) - call ac%set_asb() - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') - goto 9999 - end if - - if (np>1) then - call op_prol%mv_to(acsr1) - nzl = acsr1%get_nzeros() - call psb_glob_to_loc(acsr1%ja(1:nzl),desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') - goto 9999 - end if - call op_prol%mv_from(acsr1) - endif - call op_prol%set_ncols(desc_ac%get_local_cols()) - - if (np>1) then - !call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_) - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_ac,info,'I') - call tmpcoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(tmpcoo) - if (info == psb_success_) call op_restr%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Converting op_restr to local') - goto 9999 - end if - end if - ! - ! Clip to local rows. - ! - call op_restr%set_nrows(desc_ac%get_local_rows()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - ! If we are here, it means we assume that an IPK version of the - ! coarse matrix can hold all indices. User beware! - ! - - ! - ! op_prol/op_restr come from par_spmm_bld with local sizes - ! suitable for DIST option, fix relevant sizes - ! - call op_prol%set_ncols(ntaggr) - call op_restr%set_nrows(ntaggr) - call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(desc_ac,info) - if (info == psb_success_) call ac%mv_to(acoo) - if (info == psb_success_) call tmp_ac%mv_from(acoo) - if (info == psb_success_) & - & call psb_gather(ac,tmp_ac,desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if (info /= psb_success_) goto 9999 - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - else - - select case(parms%coarse_mat) - - case(mld_distr_mat_) - - call ac%cscnv(info,type='csr') - call op_prol%cscnv(info,type='csr') - call op_restr%cscnv(info,type='csr') - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call op_prol%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') - call op_prol%mv_from(tmpcoo) - - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') - call op_restr%mv_from(tmpcoo) - - call op_prol%set_ncols(ntaggr) - call op_restr%set_nrows(ntaggr) - - call ac%mv_to(tmpcoo) - call tmp_ac%mv_from(tmpcoo) - call psb_gather(ac,tmp_ac,desc_ac,info,root=-ione,dupl=psb_dupl_add_,keeploc=.false.) - - call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(desc_ac,info) - ! - ! Now that we have the descriptors and the restrictor, we should - ! update the W. But we don't, because REPL is only valid - ! at the coarsest level, so no need to carry over. - ! - - if (info /= psb_success_) goto 9999 - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - end if call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/aggregator/mld_d_spmm_bld_inner.f90 b/mlprec/impl/aggregator/mld_d_spmm_bld_inner.f90 index 0eed142b..68a2c0ae 100644 --- a/mlprec/impl/aggregator/mld_d_spmm_bld_inner.f90 +++ b/mlprec/impl/aggregator/mld_d_spmm_bld_inner.f90 @@ -90,210 +90,99 @@ subroutine mld_d_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,& naggrp1 = sum(nlaggr(1:me+1)) !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr - if (.false.) then - ! - ! COO_PROL should arrive here with local numbering - ! - if (debug) write(0,*) me,' ',trim(name),' Size check on entry New: ',& - & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),& - & nrow,ntaggr,naggr - - call coo_prol%cp_to_ifmt(csr_prol,info) - - if (debug) write(0,*) me,trim(name),' Product AxPROL ',& - & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), & - & desc_a%get_local_rows(),desc_a%get_local_cols(),& - & desc_ac%get_local_rows(),desc_a%get_local_cols() - if (debug) flush(0) - - if (do_timings) call psb_tic(idx_spspmm) - call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info) - if (do_timings) call psb_toc(idx_spspmm) - - if (debug) write(0,*) me,trim(name),' Done AxPROL ',& - & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),& - & desc_ac%get_local_rows(),desc_ac%get_local_cols() - - ! - ! Ok first product done. - ! - ! Remember that RESTR must be built from PROL after halo extension, - ! which is done above in psb_par_spspmm - if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',& - & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros() - call csr_prol%cp_to_lcoo(coo_restr,info) + ! + ! COO_PROL should arrive here with local numbering + ! + if (debug) write(0,*) me,' ',trim(name),' Size check on entry New: ',& + & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),& + & nrow,ntaggr,naggr + + call coo_prol%cp_to_ifmt(csr_prol,info) + + if (debug) write(0,*) me,trim(name),' Product AxPROL ',& + & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), & + & desc_a%get_local_rows(),desc_a%get_local_cols(),& + & desc_ac%get_local_rows(),desc_a%get_local_cols() + if (debug) flush(0) + + if (do_timings) call psb_tic(idx_spspmm) + call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info) + if (do_timings) call psb_toc(idx_spspmm) + + if (debug) write(0,*) me,trim(name),' Done AxPROL ',& + & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),& + & desc_ac%get_local_rows(),desc_ac%get_local_cols() + + ! + ! Ok first product done. + ! + ! Remember that RESTR must be built from PROL after halo extension, + ! which is done above in psb_par_spspmm + if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',& + & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros() + call csr_prol%mv_to_lcoo(coo_restr,info) !!$ write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),& !!$ & coo_restr%get_ncols(),coo_restr%get_nzeros() - call coo_restr%transp() - nzl = coo_restr%get_nzeros() - call desc_ac%l2gip(coo_restr%ia(1:nzl),info) - i=0 - ! - ! Now we have to fix this. The only rows of the restrictor that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then - i = i+1 - coo_restr%val(i) = coo_restr%val(k) - coo_restr%ia(i) = coo_restr%ia(k) - coo_restr%ja(i) = coo_restr%ja(k) - end if - end do - call coo_restr%set_nzeros(i) - call coo_restr%fix(info) - call coo_restr%cp_to_coo(tmpcoo,info) -!!$ write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros() - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'starting sphalo/ rwxtd' - nzl = tmpcoo%get_nzeros() - call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_ac,info,iact='I',owned=.true.) - call tmpcoo%clean_negidx(info) - nzl = tmpcoo%get_nzeros() - call tmpcoo%set_nrows(desc_ac%get_local_rows()) - call tmpcoo%set_ncols(desc_a%get_local_cols()) -!!$ write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros() - call csr_restr%mv_from_lcoo(tmpcoo,info) - - if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',& - & csr_restr%get_nrows(),csr_restr%get_ncols(), & - & desc_ac%get_local_rows(),desc_a%get_local_cols(),& - & acsr3%get_nrows(),acsr3%get_ncols() - if (do_timings) call psb_tic(idx_spspmm) - call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info) - if (do_timings) call psb_toc(idx_spspmm) - call csr_restr%free() - call acsr3%free() - call ac_csr%mv_to_lcoo(ac_coo,info) - call ac_coo%fix(info) - nza = ac_coo%get_nzeros() - if (debug) write(0,*) me,trim(name),' Fixed ac ',& - & ac_coo%get_nrows(),ac_coo%get_ncols(), nza - call desc_ac%indxmap%l2gip(ac_coo%ia(1:nza),info) - call desc_ac%indxmap%l2gip(ac_coo%ja(1:nza),info) - call ac_coo%set_nrows(ntaggr) - call ac_coo%set_ncols(ntaggr) - if (debug) write(0,*) me,' ',trim(name),' Before mv_from',psb_get_errstatus() - if (info == 0) call ac%mv_from(ac_coo) - if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus() - if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr - ! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros() - - nza = coo_prol%get_nzeros() - call desc_ac%indxmap%l2gip(coo_prol%ja(1:nza),info) - - if (debug) then - write(0,*) me,' ',trim(name),' Checkpoint at exit' - call psb_barrier(ictxt) - write(0,*) me,' ',trim(name),' Checkpoint through' + if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr) + + call coo_restr%transp() + nzl = coo_restr%get_nzeros() + nrl = desc_ac%get_local_rows() + i=0 + ! + ! Only keep local rows + ! + do k=1, nzl + if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then + i = i+1 + coo_restr%val(i) = coo_restr%val(k) + coo_restr%ia(i) = coo_restr%ia(k) + coo_restr%ja(i) = coo_restr%ja(k) end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3') - goto 9999 - end if - - else - ! - ! COO_PROL should arrive here with local numbering - ! - if (debug) write(0,*) me,' ',trim(name),' Size check on entry New: ',& - & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),& - & nrow,ntaggr,naggr - - call coo_prol%cp_to_ifmt(csr_prol,info) - - if (debug) write(0,*) me,trim(name),' Product AxPROL ',& - & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), & - & desc_a%get_local_rows(),desc_a%get_local_cols(),& - & desc_ac%get_local_rows(),desc_a%get_local_cols() - if (debug) flush(0) - - if (do_timings) call psb_tic(idx_spspmm) - call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info) - if (do_timings) call psb_toc(idx_spspmm) - - if (debug) write(0,*) me,trim(name),' Done AxPROL ',& - & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),& - & desc_ac%get_local_rows(),desc_ac%get_local_cols() - - ! - ! Ok first product done. - ! - ! Remember that RESTR must be built from PROL after halo extension, - ! which is done above in psb_par_spspmm - if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',& - & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros() - call csr_prol%mv_to_lcoo(coo_restr,info) -!!$ write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),& -!!$ & coo_restr%get_ncols(),coo_restr%get_nzeros() - if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr) - - call coo_restr%transp() - nzl = coo_restr%get_nzeros() - nrl = desc_ac%get_local_rows() - i=0 - ! - ! Only keep local rows - ! - do k=1, nzl - if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then - i = i+1 - coo_restr%val(i) = coo_restr%val(k) - coo_restr%ia(i) = coo_restr%ia(k) - coo_restr%ja(i) = coo_restr%ja(k) - end if - end do - call coo_restr%set_nzeros(i) - call coo_restr%fix(info) - nzl = coo_restr%get_nzeros() - call coo_restr%set_nrows(desc_ac%get_local_rows()) - call coo_restr%set_ncols(desc_a%get_local_cols()) - if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr) - call csr_restr%cp_from_lcoo(coo_restr,info) + end do + call coo_restr%set_nzeros(i) + call coo_restr%fix(info) + nzl = coo_restr%get_nzeros() + call coo_restr%set_nrows(desc_ac%get_local_rows()) + call coo_restr%set_ncols(desc_a%get_local_cols()) + if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr) + call csr_restr%cp_from_lcoo(coo_restr,info) !!$ write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros() - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'starting sphalo/ rwxtd' - - if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',& - & csr_restr%get_nrows(),csr_restr%get_ncols(), & - & desc_ac%get_local_rows(),desc_a%get_local_cols(),& - & acsr3%get_nrows(),acsr3%get_ncols() - if (do_timings) call psb_tic(idx_spspmm) - call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info) - if (do_timings) call psb_toc(idx_spspmm) - call acsr3%free() - - call psb_cdasb(desc_ac,info) - - call ac_csr%set_nrows(desc_ac%get_local_rows()) - call ac_csr%set_ncols(desc_ac%get_local_cols()) - call ac%mv_from(ac_csr) - call ac%set_asb() - - if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus() - if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr - ! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros() - - call coo_prol%set_ncols(desc_ac%get_local_cols()) - !call coo_restr%mv_from_ifmt(csr_restr,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',& + & csr_restr%get_nrows(),csr_restr%get_ncols(), & + & desc_ac%get_local_rows(),desc_a%get_local_cols(),& + & acsr3%get_nrows(),acsr3%get_ncols() + if (do_timings) call psb_tic(idx_spspmm) + call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info) + if (do_timings) call psb_toc(idx_spspmm) + call acsr3%free() + + call psb_cdasb(desc_ac,info) + + call ac_csr%set_nrows(desc_ac%get_local_rows()) + call ac_csr%set_ncols(desc_ac%get_local_cols()) + call ac%mv_from(ac_csr) + call ac%set_asb() + + if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus() + if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr + ! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros() + + call coo_prol%set_ncols(desc_ac%get_local_cols()) + !call coo_restr%mv_from_ifmt(csr_restr,info) !!$ call coo_restr%set_nrows(desc_ac%get_local_rows()) !!$ call coo_restr%set_ncols(desc_a%get_local_cols()) - if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr) - end if + if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -377,209 +266,100 @@ subroutine mld_ld_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,& naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr - if (.false.) then - ! - ! Here COO_PROL should be with GLOBAL indices on the cols - ! and LOCAL indices on the rows. - ! - if (debug) write(0,*) me,' ',trim(name),' Size check on entry New: ',& - & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),& - & nrow,ntaggr,naggr - - call coo_prol%cp_to_fmt(csr_prol,info) - - if (debug) write(0,*) me,trim(name),' Product AxPROL ',& - & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), & - & desc_a%get_local_rows(),desc_a%get_local_cols(),& - & desc_ac%get_local_rows(),desc_a%get_local_cols() - if (debug) flush(0) - - if (do_timings) call psb_tic(idx_spspmm) - call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info) - if (do_timings) call psb_toc(idx_spspmm) - - if (debug) write(0,*) me,trim(name),' Done AxPROL ',& - & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),& - & desc_ac%get_local_rows(),desc_ac%get_local_cols() - - ! - ! Ok first product done. - ! - ! Remember that RESTR must be built from PROL after halo extension, - ! which is done above in psb_par_spspmm - if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',& - & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros() - call csr_prol%cp_to_fmt(coo_restr,info) -!!$ write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),& -!!$ & coo_restr%get_ncols(),coo_restr%get_nzeros() - call coo_restr%transp() - nzl = coo_restr%get_nzeros() - call desc_ac%l2gip(coo_restr%ia(1:nzl),info) - i=0 - ! - ! Now we have to fix this. The only rows of the restrictor that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then - i = i+1 - coo_restr%val(i) = coo_restr%val(k) - coo_restr%ia(i) = coo_restr%ia(k) - coo_restr%ja(i) = coo_restr%ja(k) - end if - end do - call coo_restr%set_nzeros(i) - call coo_restr%fix(info) - call coo_restr%cp_to_coo(tmpcoo,info) -!!$ write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros() - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'starting sphalo/ rwxtd' - nzl = tmpcoo%get_nzeros() - call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_ac,info,iact='I',owned=.true.) - call tmpcoo%clean_negidx(info) - nzl = tmpcoo%get_nzeros() - call tmpcoo%set_nrows(desc_ac%get_local_rows()) - call tmpcoo%set_ncols(desc_a%get_local_cols()) -!!$ write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros() - call csr_restr%mv_from_coo(tmpcoo,info) - - if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',& - & csr_restr%get_nrows(),csr_restr%get_ncols(), & - & desc_ac%get_local_rows(),desc_a%get_local_cols(),& - & acsr3%get_nrows(),acsr3%get_ncols() - if (do_timings) call psb_tic(idx_spspmm) - call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info) - if (do_timings) call psb_toc(idx_spspmm) - call csr_restr%free() - call ac_csr%mv_to_coo(ac_coo,info) - nza = ac_coo%get_nzeros() - if (debug) write(0,*) me,trim(name),' Fixing ac ',& - & ac_coo%get_nrows(),ac_coo%get_ncols(), nza - call ac_coo%fix(info) - call desc_ac%indxmap%l2gip(ac_coo%ia(1:nza),info) - call desc_ac%indxmap%l2gip(ac_coo%ja(1:nza),info) - call ac_coo%set_nrows(ntaggr) - call ac_coo%set_ncols(ntaggr) - if (debug) write(0,*) me,' ',trim(name),' Before mv_from',psb_get_errstatus() - if (info == 0) call ac%mv_from(ac_coo) - if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus() - if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr - ! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros() - - nza = coo_prol%get_nzeros() - call desc_ac%indxmap%l2gip(coo_prol%ja(1:nza),info) - - if (debug) then - write(0,*) me,' ',trim(name),' Checkpoint at exit' - call psb_barrier(ictxt) - write(0,*) me,' ',trim(name),' Checkpoint through' - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3') - goto 9999 - end if - else - ! - ! COO_PROL should arrive here with local numbering - ! - if (debug) write(0,*) me,' ',trim(name),' Size check on entry New: ',& - & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),& - & nrow,ntaggr,naggr - - call coo_prol%cp_to_fmt(csr_prol,info) - - if (debug) write(0,*) me,trim(name),' Product AxPROL ',& - & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), & - & desc_a%get_local_rows(),desc_a%get_local_cols(),& - & desc_ac%get_local_rows(),desc_a%get_local_cols() - if (debug) flush(0) - - if (do_timings) call psb_tic(idx_spspmm) - call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info) - if (do_timings) call psb_toc(idx_spspmm) - - if (debug) write(0,*) me,trim(name),' Done AxPROL ',& - & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),& - & desc_ac%get_local_rows(),desc_ac%get_local_cols() - - ! - ! Ok first product done. - ! - ! Remember that RESTR must be built from PROL after halo extension, - ! which is done above in psb_par_spspmm - if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',& - & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros() - call csr_prol%mv_to_coo(coo_restr,info) + ! + ! COO_PROL should arrive here with local numbering + ! + if (debug) write(0,*) me,' ',trim(name),' Size check on entry New: ',& + & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),& + & nrow,ntaggr,naggr + + call coo_prol%cp_to_fmt(csr_prol,info) + + if (debug) write(0,*) me,trim(name),' Product AxPROL ',& + & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), & + & desc_a%get_local_rows(),desc_a%get_local_cols(),& + & desc_ac%get_local_rows(),desc_a%get_local_cols() + if (debug) flush(0) + + if (do_timings) call psb_tic(idx_spspmm) + call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info) + if (do_timings) call psb_toc(idx_spspmm) + + if (debug) write(0,*) me,trim(name),' Done AxPROL ',& + & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),& + & desc_ac%get_local_rows(),desc_ac%get_local_cols() + + ! + ! Ok first product done. + ! + ! Remember that RESTR must be built from PROL after halo extension, + ! which is done above in psb_par_spspmm + if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',& + & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros() + call csr_prol%mv_to_coo(coo_restr,info) !!$ write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),& !!$ & coo_restr%get_ncols(),coo_restr%get_nzeros() - if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr) - - call coo_restr%transp() - nzl = coo_restr%get_nzeros() - nrl = desc_ac%get_local_rows() - i=0 - ! - ! Only keep local rows - ! - do k=1, nzl - if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then - i = i+1 - coo_restr%val(i) = coo_restr%val(k) - coo_restr%ia(i) = coo_restr%ia(k) - coo_restr%ja(i) = coo_restr%ja(k) - end if - end do - call coo_restr%set_nzeros(i) - call coo_restr%fix(info) - nzl = coo_restr%get_nzeros() - call coo_restr%set_nrows(desc_ac%get_local_rows()) - call coo_restr%set_ncols(desc_a%get_local_cols()) - if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr) - call csr_restr%cp_from_coo(coo_restr,info) + if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr) + + call coo_restr%transp() + nzl = coo_restr%get_nzeros() + nrl = desc_ac%get_local_rows() + i=0 + ! + ! Only keep local rows + ! + do k=1, nzl + if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then + i = i+1 + coo_restr%val(i) = coo_restr%val(k) + coo_restr%ia(i) = coo_restr%ia(k) + coo_restr%ja(i) = coo_restr%ja(k) + end if + end do + call coo_restr%set_nzeros(i) + call coo_restr%fix(info) + nzl = coo_restr%get_nzeros() + call coo_restr%set_nrows(desc_ac%get_local_rows()) + call coo_restr%set_ncols(desc_a%get_local_cols()) + if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr) + call csr_restr%cp_from_coo(coo_restr,info) !!$ write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros() - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'starting sphalo/ rwxtd' - - if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',& - & csr_restr%get_nrows(),csr_restr%get_ncols(), & - & desc_ac%get_local_rows(),desc_a%get_local_cols(),& - & acsr3%get_nrows(),acsr3%get_ncols() - if (do_timings) call psb_tic(idx_spspmm) - call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info) - if (do_timings) call psb_toc(idx_spspmm) - call acsr3%free() - - call psb_cdasb(desc_ac,info) - - call ac_csr%set_nrows(desc_ac%get_local_rows()) - call ac_csr%set_ncols(desc_ac%get_local_cols()) - call ac%mv_from(ac_csr) - call ac%set_asb() - - if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus() - if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr - ! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros() - - call coo_prol%set_ncols(desc_ac%get_local_cols()) - !call coo_restr%mv_from_ifmt(csr_restr,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr') + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',& + & csr_restr%get_nrows(),csr_restr%get_ncols(), & + & desc_ac%get_local_rows(),desc_a%get_local_cols(),& + & acsr3%get_nrows(),acsr3%get_ncols() + if (do_timings) call psb_tic(idx_spspmm) + call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info) + if (do_timings) call psb_toc(idx_spspmm) + call acsr3%free() + + call psb_cdasb(desc_ac,info) + + call ac_csr%set_nrows(desc_ac%get_local_rows()) + call ac_csr%set_ncols(desc_ac%get_local_cols()) + call ac%mv_from(ac_csr) + call ac%set_asb() + + if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus() + if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr + ! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros() + + call coo_prol%set_ncols(desc_ac%get_local_cols()) + !call coo_restr%mv_from_ifmt(csr_restr,info) !!$ call coo_restr%set_nrows(desc_ac%get_local_rows()) !!$ call coo_restr%set_ncols(desc_a%get_local_cols()) - if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr) - end if + if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr) if (debug_level >= psb_debug_outer_) & diff --git a/mlprec/impl/aggregator/mld_daggrmat_nosmth_bld.f90 b/mlprec/impl/aggregator/mld_daggrmat_nosmth_bld.f90 index 27fd0fb5..11cf0ef5 100644 --- a/mlprec/impl/aggregator/mld_daggrmat_nosmth_bld.f90 +++ b/mlprec/impl/aggregator/mld_daggrmat_nosmth_bld.f90 @@ -164,7 +164,6 @@ subroutine mld_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,& call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,& & coo_prol,desc_ac,coo_restr,info) - !call psb_cdasb(desc_ac,info) call coo_restr%set_nrows(desc_ac%get_local_rows()) call coo_restr%set_ncols(desc_a%get_local_cols()) call coo_prol%set_nrows(desc_a%get_local_rows())