From 23f84ce236eca09404bad7066399984914a1d407 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Mon, 13 Jul 2026 15:42:23 +0200 Subject: [PATCH] First working version --- amgprec/amg_d_onelev_mod.f90 | 8 +- amgprec/amg_d_prec_type.f90 | 19 +- amgprec/impl/amg_d_hierarchy_bld.F90 | 178 +++++++----------- amgprec/impl/amg_dfile_prec_descr.f90 | 3 +- amgprec/impl/amg_dmlprec_aply.f90 | 8 +- amgprec/impl/amg_dprecinit.F90 | 3 +- .../impl/level/amg_d_base_onelev_map_rstr.F90 | 26 +-- samples/advanced/remap/amg_d_pde3d.F90 | 20 +- 8 files changed, 110 insertions(+), 155 deletions(-) diff --git a/amgprec/amg_d_onelev_mod.f90 b/amgprec/amg_d_onelev_mod.f90 index 29b7f942..23150b4c 100644 --- a/amgprec/amg_d_onelev_mod.f90 +++ b/amgprec/amg_d_onelev_mod.f90 @@ -762,7 +762,7 @@ contains info = psb_success_ nwv = lv%get_wrksz() if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) - write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() +!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() if (info == 0) then if (lv%remap_data%desc_ac_pre_remap%is_asb()) then ! @@ -810,12 +810,12 @@ contains info = psb_success_ call wk%free(info) - write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& - & present(desc2),desc%is_valid() +!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& +!!$ & present(desc2),desc%is_valid() allocate(wk%wv(nwv),stat=info) if (present(desc2).and.(desc%is_valid())) then - write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() +!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() if (desc2%get_local_cols()>desc%get_local_cols()) then call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) else diff --git a/amgprec/amg_d_prec_type.f90 b/amgprec/amg_d_prec_type.f90 index 40d53dd0..29335283 100644 --- a/amgprec/amg_d_prec_type.f90 +++ b/amgprec/amg_d_prec_type.f90 @@ -437,11 +437,11 @@ contains class(amg_dprec_type), intent(in) :: prec integer(psb_ipk_) :: val val = 0 - if (allocated(prec%precv)) then - val = size(prec%precv) - end if +!!$ if (allocated(prec%precv)) then +!!$ val = size(prec%precv) +!!$ end if val = prec%nlevs - write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv) +!!$ write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv) end function amg_d_get_nlevs @@ -532,9 +532,9 @@ contains if (num >= dzero) then den = num nl = prec%get_nlevs() - write(0,*) 'Inside cmp_compl ',nl,size(prec%precv) +!!$ write(0,*) 'Inside cmp_compl ',nl,size(prec%precv) do il=2, nl - write(0,*) ' ',il,associated(prec%precv(il)%base_a) +!!$ write(0,*) ' ',il,associated(prec%precv(il)%base_a) num = num + max(0,prec%precv(il)%base_a%get_nzeros()) end do end if @@ -627,9 +627,7 @@ contains end subroutine amg_dprecfree subroutine amg_d_prec_free(prec,info) - implicit none - ! Arguments class(amg_dprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -661,9 +659,7 @@ contains end subroutine amg_d_prec_free subroutine amg_d_smoothers_free(prec,info) - implicit none - ! Arguments class(amg_dprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -927,7 +923,6 @@ contains end subroutine amg_d_clone subroutine amg_d_inner_clone(prec,precout,info) - implicit none class(amg_dprec_type), intent(inout) :: prec class(psb_dprec_type), target, intent(inout) :: precout @@ -1012,7 +1007,6 @@ contains subroutine amg_d_allocate_wrk(prec,info,vmold,desc) use psb_base_mod implicit none - ! Arguments class(amg_dprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -1090,7 +1084,6 @@ contains function amg_d_is_allocated_wrk(prec) result(res) use psb_base_mod implicit none - ! Arguments class(amg_dprec_type), intent(in) :: prec logical :: res diff --git a/amgprec/impl/amg_d_hierarchy_bld.F90 b/amgprec/impl/amg_d_hierarchy_bld.F90 index 96f5f034..e8540a51 100644 --- a/amgprec/impl/amg_d_hierarchy_bld.F90 +++ b/amgprec/impl/amg_d_hierarchy_bld.F90 @@ -243,7 +243,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) goto 9999 end if ! - ! First set desired number of levels + ! First set desired number of levels if different from default. ! if (iszv /= nplevs) then allocate(tprecv(nplevs),stat=info) @@ -292,6 +292,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) call prec%set_nlevs(nplevs) iszv = prec%get_nlevs() end if + ! ! Finest level first; create a GEN_BLOCK ! copy of the descriptor. @@ -305,6 +306,10 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info) prec%precv(1)%base_desc => prec%precv(1)%desc_ac + + ! + ! Main build loop + ! newsz = 0 stop_hierarchy_loop = .false. array_build_loop: do i=2, iszv @@ -313,9 +318,12 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) ! on all processes. ! call psb_bcast(ctxt,prec%precv(i)%parms) + ! + ! Get current context: might have performed remapping + ! lctxt = prec%precv(i-1)%base_desc%get_ctxt() call psb_info(lctxt,lme,lnp) - write(0,*) 'Check at level',i,lme,lnp +!!$ write(0,*) 'Check at level',i,lme,lnp ! ! Sanity checks on the parameters ! @@ -331,8 +339,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) & write(debug_unit,*) me,' ',trim(name),& & 'Calling mlprcbld at level ',i ! - ! Build the mapping between levels i-1 and i and the matrix - ! at level i + ! Build the tentative mapping between levels i-1 and i + ! and the matrixat level i ! if (do_timings) call psb_tic(idx_bldtp) if (info == psb_success_)& @@ -355,22 +363,25 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) ! call op_prol%clone(prec%precv(i)%tprol,info) - ! ! Check for early termination of aggregation loop. ! if (i == 2) then - call amg_hierarchy_bld_newsz(i,iszv,& - & desc_a%get_global_rows(),nlaggr,mnaggratio,sizeratio,newsz) + call amg_d_hierarchy_bld_cmp_newsz(i,iszv,& + & desc_a%get_global_rows(),& + & nlaggr,casize,mnaggratio,sizeratio,newsz) else - call amg_hierarchy_bld_newsz(i,iszv,& - & sum(prec%precv(i-1)%linmap%naggr),nlaggr,mnaggratio,sizeratio,newsz) + call amg_d_hierarchy_bld_cmp_newsz(i,iszv,& + & sum(prec%precv(i-1)%linmap%naggr),& + & nlaggr,casize,mnaggratio,sizeratio,newsz) end if prec%precv(i)%szratio = sizeratio call psb_bcast(ctxt,newsz) + ! ! Handle reallocation, if needed, and then mat_asb to polish off the - ! construction + ! construction + ! if (newsz > 0) then ! ! This is awkward, we are saving the aggregation parms, for the sake @@ -405,8 +416,6 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) goto 9999 endif !!$ write(0,*) ' Early exit of array_build_loop',i,iszv,info,& -!!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() -!!$ exit array_build_loop level = newsz stop_hierarchy_loop = .true. else @@ -420,27 +429,27 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) ! ! Do we want to remap onto a smaller subset of processes? + ! Will need a more sophisticated policy ! - - if (amg_policy_do_remap(level,sum(nlaggr))) then - block - type(psb_ctxt_type) :: lctxt - integer(psb_ipk_) :: lme,lnp - lctxt = prec%precv(level)%desc_ac%get_ctxt() - call psb_info(lctxt,lme,lnp) - write(0,*) ' Context on remapping ',lme,lnp + block + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp + lctxt = prec%precv(level)%desc_ac%get_ctxt() + call psb_info(lctxt,lme,lnp) + if (amg_d_policy_do_remap(lctxt,level,sum(nlaggr))) then +!!$ write(0,*) ' Context on remapping ',lme,lnp if ((lme >=0).and.(lnp>=2)) then associate(lv=>prec%precv(level), rmp => prec%precv(level)%remap_data) call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) call lv%ac%clone(rmp%ac_pre_remap,info) - write(0,*) 'During first remapping desc_ac:',lv%desc_ac%is_asb(),& - & rmp%desc_ac_pre_remap%is_asb() - write(0,*) ' First Doing remapping ',lnp, lnp/2 +!!$ write(0,*) 'During first remapping desc_ac:',lv%desc_ac%is_asb(),& +!!$ & rmp%desc_ac_pre_remap%is_asb() +!!$ write(0,*) ' First Doing remapping ',lnp, lnp/2 call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) !!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& !!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) - write(0,*) 'First Assignment ',size(lv%linmap%naggr),size(rmp%naggr) +!!$ write(0,*) 'First Assignment ',size(lv%linmap%naggr),size(rmp%naggr) lv%linmap%naggr(:) = rmp%naggr(:) lv%linmap%p_desc_V => rmp%desc_ac_pre_remap lv%base_a => lv%ac @@ -452,16 +461,16 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) call psb_info(ct,meu,npu) ct = lv%linmap%p_desc_V%get_ctxt() call psb_info(ct,mev,npv) - write(0,*) 'First Check on out remapping ',i,& - & rmp%desc_ac_pre_remap%is_asb(),& - & ':',meu,npu,mev,npv +!!$ write(0,*) 'First Check on out remapping ',i,& +!!$ & rmp%desc_ac_pre_remap%is_asb(),& +!!$ & ':',meu,npu,mev,npv end block end associate end if - end block - write(0,*) 'Second Check on out remapping ',level,& - & prec%precv(level)%remap_data%desc_ac_pre_remap%is_asb() - end if +!!$ write(0,*) 'Second Check on out remapping ',level,& +!!$ & prec%precv(level)%remap_data%desc_ac_pre_remap%is_asb(), newsz + end if + end block if (info /= psb_success_) then write(ch_err,'(a,i7)') 'Mat asb fail @ level ',i @@ -476,82 +485,31 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) end if end do array_build_loop - write(0,*) ' Done array_build_loop',iszv,newsz,info,psb_errstatus_fatal() +!!$ write(0,*) ' Done array_build_loop',iszv,newsz,info,psb_errstatus_fatal() if (newsz>0) then - do i=2,newsz - write(0,*) me,'Newsz Out of array_build_loop ',i,':',& - & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() - end do - write(0,*) 'Calling set_nlevs ',newsz +!!$ do i=2,newsz +!!$ write(0,*) me,'Newsz Out of array_build_loop ',i,':',& +!!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() +!!$ end do +!!$ write(0,*) 'Calling set_nlevs ',newsz call prec%set_nlevs(newsz) else - do i=2, iszv - write(0,*) me,'Out of array_build_loop ',i,':',& - & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() - end do +!!$ do i=2, iszv +!!$ write(0,*) me,'Out of array_build_loop ',i,':',& +!!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() +!!$ end do end if iszv = prec%get_nlevs() call psb_barrier(ctxt) - if (.false.) then - if (newsz > 0) then - ! - ! We exited early from the build loop, need to fix - ! the size. - ! - allocate(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz - call prec%precv(i)%move_alloc(tprecv(i),info) - end do - do i=newsz+1, iszv - call prec%precv(i)%free(info) - end do - call move_alloc(tprecv,prec%precv) - ! Ignore errors from transfer - info = psb_success_ - ! - ! Restart - iszv = newsz - ! Fix the pointers, but the level 1 should - ! be treated differently - if (.not.associated(prec%precv(1)%base_a,a)) then - prec%precv(1)%base_a => prec%precv(1)%ac - end if - if (.not.associated(prec%precv(1)%base_desc,desc_a)) then - prec%precv(1)%base_desc => prec%precv(1)%desc_ac - end if - do i=2, iszv - prec%precv(i)%base_a => prec%precv(i)%ac - prec%precv(i)%base_desc => prec%precv(i)%desc_ac - ! This is needed when the linmap object has been built - ! reusing the base_desc descriptor through a pointer. - ! With PSBLAS 4 we will have a better solution - if (associated(prec%precv(i)%linmap%p_desc_U)) & - & prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc - if (associated(prec%precv(i)%linmap%p_desc_V))& - & prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc - end do - end if - else - if (.not.associated(prec%precv(1)%base_a,a)) then - prec%precv(1)%base_a => prec%precv(1)%ac - end if - if (.not.associated(prec%precv(1)%base_desc,desc_a)) then - prec%precv(1)%base_desc => prec%precv(1)%desc_ac - end if - end if - write(0,*) ' Done reallocating precv',iszv,newsz,info - do i=2, iszv - write(0,*) me,'At end of hierarchy_bld level',i,':',& - & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() - end do +!!$ write(0,*) ' Done reallocating precv',iszv,newsz,info +!!$ +!!$ do i=2, iszv +!!$ write(0,*) me,'At end of hierarchy_bld level',i,':',& +!!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() +!!$ end do call psb_barrier(ctxt) @@ -562,8 +520,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) endif iszv = prec%get_nlevs() - write(0,*) 'Going for cmp_complexity ',& - & allocated(prec%precv),iszv,size(prec%precv) +!!$ write(0,*) 'Going for cmp_complexity ',& +!!$ & allocated(prec%precv),iszv,size(prec%precv) call prec%cmp_complexity() call prec%cmp_avg_cr() @@ -704,34 +662,37 @@ contains end subroutine restore_smoothers #endif - function amg_policy_do_remap(level,aggsize) result(res) + function amg_d_policy_do_remap(ctxt,level,aggsize) result(res) logical :: res + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: level integer(psb_lpk_) :: aggsize res = amg_get_do_remap().and.(level>=2) !!$ res = .false. - end function amg_policy_do_remap + end function amg_d_policy_do_remap - subroutine amg_hierarchy_bld_newsz(level,iszv,prevsize,& - & nlaggr,mnratio,sizeratio,newsz) + subroutine amg_d_hierarchy_bld_cmp_newsz(level,iszv,prevsize,& + & nlaggr,casize,mnratio,sizeratio,newsz) implicit none integer(psb_ipk_) :: level,iszv,newsz integer(psb_lpk_) :: nlaggr(:) - integer(psb_lpk_) :: prevsize + integer(psb_lpk_) :: prevsize, casize real(psb_dpk_) :: mnratio, sizeratio ! ============================== - integer(psb_lpk_) :: iaggsize, casize + integer(psb_lpk_) :: iaggsize newsz = 0 iaggsize = sum(nlaggr) sizeratio = prevsize sizeratio = sizeratio/iaggsize +!!$ write(0,*) 'From cmp_newsz: ',iaggsize,casize,& +!!$ & sizeratio,mnratio, level if (iaggsize <= casize) newsz = level if (level == iszv) newsz = level if (level>2) then - if (sizeratio < mnaggratio) then + if (sizeratio < mnratio) then if (sizeratio > 1) then newsz = level else @@ -742,6 +703,7 @@ contains end if end if end if - end subroutine amg_hierarchy_bld_newsz +!!$ write(0,*) 'At end of cmp_newsz ',newsz + end subroutine amg_d_hierarchy_bld_cmp_newsz end subroutine amg_d_hierarchy_bld diff --git a/amgprec/impl/amg_dfile_prec_descr.f90 b/amgprec/impl/amg_dfile_prec_descr.f90 index b27d2c4c..6be69065 100644 --- a/amgprec/impl/amg_dfile_prec_descr.f90 +++ b/amgprec/impl/amg_dfile_prec_descr.f90 @@ -130,8 +130,6 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix) ! if (me == root_) then nlev = prec%get_nlevs() - write(0,*) 'From file_prec_descr: nlev ',nlev - flush(0) do ilev = 1, nlev if (.not.allocated(prec%precv(ilev)%sm)) then info = 3111 @@ -143,6 +141,7 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix) write(iout_,*) write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description' + write(iout_,*) 'At level :',1,' we have ',np,' processes' if (nlev == 1) then ! diff --git a/amgprec/impl/amg_dmlprec_aply.f90 b/amgprec/impl/amg_dmlprec_aply.f90 index 633ebd5b..d0b3e0ad 100644 --- a/amgprec/impl/amg_dmlprec_aply.f90 +++ b/amgprec/impl/amg_dmlprec_aply.f90 @@ -605,7 +605,7 @@ contains if(debug_level > 1) then write(debug_unit,*) me,' inner_mult at level ',level end if - write(debug_unit,*) me,' inner_mult at level (1):',level,np +!!$ write(debug_unit,*) me,' inner_mult at level (1):',level,np sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) @@ -615,8 +615,8 @@ contains & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & wv => p%precv(level)%wrk%wv) - write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',& - & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv) +!!$ write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',& +!!$ & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv) if (me >=0) then if (level < nlev) then @@ -664,7 +664,7 @@ contains goto 9999 end if - write(0,*) me,' Map_rstr from ', level,' to ',level+1 +!!$ write(0,*) me,' Map_rstr from ', level,' to ',level+1 call p%precv(level+1)%map_rstr(done,vty,& & dzero,p%precv(level+1)%wrk%vx2l,& & info,work=work,vtx=wv(1)) diff --git a/amgprec/impl/amg_dprecinit.F90 b/amgprec/impl/amg_dprecinit.F90 index 62ad8d96..c8cf13da 100644 --- a/amgprec/impl/amg_dprecinit.F90 +++ b/amgprec/impl/amg_dprecinit.F90 @@ -240,6 +240,8 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info) do ilev_ = 1, nlev_ call prec%precv(ilev_)%default() end do + call prec%set_nlevs(nlev_) + call prec%set('ML_CYCLE','VCYCLE',info) call prec%set('SMOOTHER_TYPE','FBGS',info) #if defined(AMG_HAVE_UMF) @@ -256,7 +258,6 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info) &': Warning: Unknown preconditioner type request "',ptype,'"' info = psb_err_pivot_too_small_ end select - call prec%set_nlevs(nlev_) call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 b/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 index dac4b3de..74e3d29f 100644 --- a/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 @@ -49,7 +49,7 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& type(psb_d_vect_type), pointer :: vty_ integer(psb_mpk_) :: me, np - write(0,*) 'New map_rstr ',lv%remap_data%ac_pre_remap%is_asb() +!!$ write(0,*) 'New map_rstr ',lv%remap_data%ac_pre_remap%is_asb() if (present(vty)) then vty_ => vty else @@ -60,7 +60,7 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& ! ! Remap has happened, deal with it ! - write(0,*) 'Level map_rstr with remapping ' +!!$ write(0,*) 'Level map_rstr with remapping ' block type(psb_ctxt_type) :: ctxt, rctxt integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp @@ -72,25 +72,25 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& call psb_info(ctxt,me,np) rctxt = lv%desc_ac%get_ctxt() call psb_info(rctxt,rme,rnp) - write(0,*) 'New context map rstr',rme,rnp,me,np +!!$ write(0,*) 'New context map rstr',rme,rnp,me,np idest = lv%remap_data%idest associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) - write(0,*) 'Should apply maps, then send data from ',me,' to ',idest - if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:) +!!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest +!!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:) nsrc = size(isrc) nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) - write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),& - & psb_errstatus_fatal() - flush(0) +!!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),& +!!$ & psb_errstatus_fatal() +!!$ flush(0) call psb_barrier(ctxt) call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& & work=work,vtx=vtx,vty=vty_) !call tv%sync() !rsnd = tv%get_vect() !call psb_snd(ctxt,rsnd(1:nrl),idest) - write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal() +!!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal() call psb_snd(ctxt,tv%v%v(1:nrl),idest) if (rme >=0) then allocate(rrcv(sum(nrsrc))) @@ -99,14 +99,14 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& do i = 1,size(isrc) ip = isrc(i) nrl = nrsrc(i) - write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal() +!!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal() call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) kp = kp + nrl end do call vect_v%set_vect(rrcv) end if end associate - write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal() +!!$ write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal() end block else @@ -115,12 +115,12 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& type(psb_ctxt_type) :: ctxt, rctxt ctxt = lv%linmap%p_desc_U%get_ctxt() call psb_info(ctxt,me,np) - write(0,*) me,' map_rstr calling U2V: ',me,np +!!$ write(0,*) me,' map_rstr calling U2V: ',me,np call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& & work=work,vtx=vtx,vty=vty_) end block end if - write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal() +!!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal() end subroutine amg_d_base_onelev_map_rstr_v subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) diff --git a/samples/advanced/remap/amg_d_pde3d.F90 b/samples/advanced/remap/amg_d_pde3d.F90 index 117e338f..95fa9f06 100644 --- a/samples/advanced/remap/amg_d_pde3d.F90 +++ b/samples/advanced/remap/amg_d_pde3d.F90 @@ -473,10 +473,10 @@ program amg_d_pde3d goto 9999 end if - do i=2, size(prec%precv) - write(0,*) iam,'Between hier and smoothers_bld level',i,':',& - & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() - end do +!!$ do i=2, size(prec%precv) +!!$ write(0,*) iam,'Between hier and smoothers_bld level',i,':',& +!!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() +!!$ end do call psb_barrier(ctxt) t1 = psb_wtime() @@ -497,11 +497,11 @@ program amg_d_pde3d write(psb_out_unit,'(" ")') end if - do i=2, size(prec%precv) - write(0,*) iam,'After smoothers_bld level',i,':',& - & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() - end do - +!!$ do i=2, size(prec%precv) +!!$ write(0,*) iam,'After smoothers_bld level',i,':',& +!!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() +!!$ end do +!!$ call prec%descr(info,iout=psb_out_unit) if (p_choice%dump) then @@ -565,7 +565,7 @@ program amg_d_pde3d call psb_sum(ctxt,amatsize) call psb_sum(ctxt,descsize) call psb_sum(ctxt,precsize) - call prec%descr(info,iout=psb_out_unit) +!!$ call prec%descr(info,iout=psb_out_unit) if (iam == psb_root_) then write(psb_out_unit,'("Computed solution on ",i8," process(es)")') np write(psb_out_unit,'("Number of threads : ",i12)') nth