From 3203682a246d643991b44745f2f20f04d6c68434 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 27 Feb 2012 18:32:07 +0000 Subject: [PATCH 02/11] mld2p4-NewML mlprec/impl/mld_cmlprec_bld.f90 mlprec/impl/mld_dmlprec_bld.f90 mlprec/impl/mld_smlprec_bld.f90 mlprec/impl/mld_zmlprec_bld.f90 Fix silly bug in broadcast. --- mlprec/impl/mld_cmlprec_bld.f90 | 292 +++++++++++++++---------------- mlprec/impl/mld_daggrmap_bld.f90 | 2 +- mlprec/impl/mld_dmlprec_bld.f90 | 292 +++++++++++++++---------------- mlprec/impl/mld_smlprec_bld.f90 | 292 +++++++++++++++---------------- mlprec/impl/mld_zmlprec_bld.f90 | 292 +++++++++++++++---------------- 5 files changed, 585 insertions(+), 585 deletions(-) diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index 6ccadf6d..b3d6430a 100644 --- a/mlprec/impl/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -162,182 +162,182 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + if (iszv > 1) then - ! - ! Build the matrix and the transfer operators corresponding - ! to the remaining levels - ! + ! + ! Build the matrix and the transfer operators corresponding + ! to the remaining levels + ! + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + call psb_bcast(ictxt,p%precv(1)%parms) + ! + ! Finest level first; remember to fix base_a and base_desc + ! + p%precv(1)%base_a => a + p%precv(1)%base_desc => desc_a + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + + + do i=2, iszv ! ! Check on the iprcparm contents: they should be the same ! on all processes. ! - call psb_bcast(ictxt,p%precv(1)%parms) - ! - ! Finest level first; remember to fix base_a and base_desc - ! - p%precv(1)%base_a => a - p%precv(1)%base_desc => desc_a - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - - - do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,p%precv(1)%parms) + call psb_bcast(ictxt,p%precv(i)%parms) + ! + ! Sanity checks on the parameters + ! + if (i= psb_debug_outer_) & - & 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 - ! - if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& - & p%precv(i-1)%base_desc, p%precv(i),info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Init upper level preconditioner') - goto 9999 - endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info - - if (i>2) then - if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit - end if - end do - - if (newsz > 0) then - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) - end if - allocate(t_prec%precv(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-1 - call mld_move_alloc(p%precv(i),t_prec%precv(i),info) - end do - call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info) - do i=newsz+1, iszv - call p%precv(i)%free(info) - end do - call mld_move_alloc(t_prec,p,info) - ! Ignore errors from transfer - info = psb_success_ - ! - ! Restart - iszv = newsz - ! Fix the pointers, but the level 1 should - ! be already OK - do i=2, iszv - 1 - p%precv(i)%base_a => p%precv(i)%ac - p%precv(i)%base_desc => p%precv(i)%desc_ac - p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc - p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc - end do - - - i = iszv - call check_coarse_lev(p%precv(i)) - if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& - & p%precv(i-1)%base_desc, p%precv(i),info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') - goto 9999 - endif end if - end if - do i=1, iszv - ! - ! build the base preconditioner at level i - ! if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Calling mlprcbld at level ',i - call mld_check_def(p%precv(i)%parms%sweeps,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - call mld_check_def(p%precv(i)%parms%sweeps_pre,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - call mld_check_def(p%precv(i)%parms%sweeps_post,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - - if (.not.allocated(p%precv(i)%sm)) then - !! Error: should have called mld_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - if (.not.allocated(p%precv(i)%sm%sv)) then - !! Error: should have called mld_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - ! - ! Test version for beginning of OO stuff. + ! Build the mapping between levels i-1 and i and the matrix + ! at level i ! - call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& - & 'F',info,amold=amold,vmold=vmold) + if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& + & p%precv(i-1)%base_desc, p%precv(i),info) - if ((info == psb_success_).and.(i>1).and.(present(amold))) then - call psb_map_cscnv(p%precv(i)%map,info,mold=amold) - call p%precv(i)%ac%cscnv(info,mold=amold) - end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='One level preconditioner build.') + & a_err='Init upper level preconditioner') goto 9999 endif if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Return from ',i,' call to mlprcbld ',info + + if (i>2) then + if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) exit + end if end do + if (newsz > 0) then + if (me == 0) then + write(debug_unit,*) trim(name),& + &': Warning: aggregates from level ',& + & newsz + write(debug_unit,*) trim(name),& + &': to level ',& + & iszv,' coincide.' + write(debug_unit,*) trim(name),& + &': Number of levels actually used :',newsz + write(debug_unit,*) + end if + allocate(t_prec%precv(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-1 + call mld_move_alloc(p%precv(i),t_prec%precv(i),info) + end do + call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info) + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call mld_move_alloc(t_prec,p,info) + ! Ignore errors from transfer + info = psb_success_ + ! + ! Restart + iszv = newsz + ! Fix the pointers, but the level 1 should + ! be already OK + do i=2, iszv - 1 + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end do + + + i = iszv + call check_coarse_lev(p%precv(i)) + if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& + & p%precv(i-1)%base_desc, p%precv(i),info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') + goto 9999 + endif + end if + end if + + do i=1, iszv + ! + ! build the base preconditioner at level i + ! + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + call mld_check_def(p%precv(i)%parms%sweeps,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%parms%sweeps_pre,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%parms%sweeps_post,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + + if (.not.allocated(p%precv(i)%sm)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + if (.not.allocated(p%precv(i)%sm%sv)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + + ! + ! Test version for beginning of OO stuff. + ! + call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& + & 'F',info,amold=amold,vmold=vmold) + + if ((info == psb_success_).and.(i>1).and.(present(amold))) then + call psb_map_cscnv(p%precv(i)%map,info,mold=amold) + call p%precv(i)%ac%cscnv(info,mold=amold) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='One level preconditioner build.') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + end do + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_daggrmap_bld.f90 b/mlprec/impl/mld_daggrmap_bld.f90 index dc049b6e..086bd6f9 100644 --- a/mlprec/impl/mld_daggrmap_bld.f90 +++ b/mlprec/impl/mld_daggrmap_bld.f90 @@ -133,7 +133,7 @@ subroutine mld_daggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info) call atmp%set_ncols(nr) if (info == psb_success_) call atrans%free() if (info == psb_success_) call atmp%cscnv(info,type='CSR') - if (info == psb_success_) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info) + if (info == psb_success_) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info) if (info == psb_success_) call atmp%free() case default diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index 18189e4b..0051fe69 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -162,182 +162,182 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + if (iszv > 1) then - ! - ! Build the matrix and the transfer operators corresponding - ! to the remaining levels - ! + ! + ! Build the matrix and the transfer operators corresponding + ! to the remaining levels + ! + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + call psb_bcast(ictxt,p%precv(1)%parms) + ! + ! Finest level first; remember to fix base_a and base_desc + ! + p%precv(1)%base_a => a + p%precv(1)%base_desc => desc_a + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + + + do i=2, iszv ! ! Check on the iprcparm contents: they should be the same ! on all processes. ! - call psb_bcast(ictxt,p%precv(1)%parms) - ! - ! Finest level first; remember to fix base_a and base_desc - ! - p%precv(1)%base_a => a - p%precv(1)%base_desc => desc_a - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - - - do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,p%precv(1)%parms) + call psb_bcast(ictxt,p%precv(i)%parms) + ! + ! Sanity checks on the parameters + ! + if (i= psb_debug_outer_) & - & 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 - ! - if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& - & p%precv(i-1)%base_desc, p%precv(i),info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Init upper level preconditioner') - goto 9999 - endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info - - if (i>2) then - if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit - end if - end do - - if (newsz > 0) then - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) - end if - allocate(t_prec%precv(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-1 - call mld_move_alloc(p%precv(i),t_prec%precv(i),info) - end do - call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info) - do i=newsz+1, iszv - call p%precv(i)%free(info) - end do - call mld_move_alloc(t_prec,p,info) - ! Ignore errors from transfer - info = psb_success_ - ! - ! Restart - iszv = newsz - ! Fix the pointers, but the level 1 should - ! be already OK - do i=2, iszv - 1 - p%precv(i)%base_a => p%precv(i)%ac - p%precv(i)%base_desc => p%precv(i)%desc_ac - p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc - p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc - end do - - - i = iszv - call check_coarse_lev(p%precv(i)) - if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& - & p%precv(i-1)%base_desc, p%precv(i),info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') - goto 9999 - endif end if - end if - do i=1, iszv - ! - ! build the base preconditioner at level i - ! if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Calling mlprcbld at level ',i - call mld_check_def(p%precv(i)%parms%sweeps,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - call mld_check_def(p%precv(i)%parms%sweeps_pre,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - call mld_check_def(p%precv(i)%parms%sweeps_post,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - - if (.not.allocated(p%precv(i)%sm)) then - !! Error: should have called mld_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - if (.not.allocated(p%precv(i)%sm%sv)) then - !! Error: should have called mld_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - ! - ! Test version for beginning of OO stuff. + ! Build the mapping between levels i-1 and i and the matrix + ! at level i ! - call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& - & 'F',info,amold=amold,vmold=vmold) + if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& + & p%precv(i-1)%base_desc, p%precv(i),info) - if ((info == psb_success_).and.(i>1).and.(present(amold))) then - call psb_map_cscnv(p%precv(i)%map,info,mold=amold) - call p%precv(i)%ac%cscnv(info,mold=amold) - end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='One level preconditioner build.') + & a_err='Init upper level preconditioner') goto 9999 endif if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Return from ',i,' call to mlprcbld ',info + + if (i>2) then + if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) exit + end if end do + if (newsz > 0) then + if (me == 0) then + write(debug_unit,*) trim(name),& + &': Warning: aggregates from level ',& + & newsz + write(debug_unit,*) trim(name),& + &': to level ',& + & iszv,' coincide.' + write(debug_unit,*) trim(name),& + &': Number of levels actually used :',newsz + write(debug_unit,*) + end if + allocate(t_prec%precv(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-1 + call mld_move_alloc(p%precv(i),t_prec%precv(i),info) + end do + call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info) + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call mld_move_alloc(t_prec,p,info) + ! Ignore errors from transfer + info = psb_success_ + ! + ! Restart + iszv = newsz + ! Fix the pointers, but the level 1 should + ! be already OK + do i=2, iszv - 1 + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end do + + + i = iszv + call check_coarse_lev(p%precv(i)) + if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& + & p%precv(i-1)%base_desc, p%precv(i),info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') + goto 9999 + endif + end if + end if + + do i=1, iszv + ! + ! build the base preconditioner at level i + ! + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + call mld_check_def(p%precv(i)%parms%sweeps,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%parms%sweeps_pre,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%parms%sweeps_post,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + + if (.not.allocated(p%precv(i)%sm)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + if (.not.allocated(p%precv(i)%sm%sv)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + + ! + ! Test version for beginning of OO stuff. + ! + call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& + & 'F',info,amold=amold,vmold=vmold) + + if ((info == psb_success_).and.(i>1).and.(present(amold))) then + call psb_map_cscnv(p%precv(i)%map,info,mold=amold) + call p%precv(i)%ac%cscnv(info,mold=amold) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='One level preconditioner build.') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + end do + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index d9d5e9bd..d49576d6 100644 --- a/mlprec/impl/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -162,182 +162,182 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + if (iszv > 1) then - ! - ! Build the matrix and the transfer operators corresponding - ! to the remaining levels - ! + ! + ! Build the matrix and the transfer operators corresponding + ! to the remaining levels + ! + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + call psb_bcast(ictxt,p%precv(1)%parms) + ! + ! Finest level first; remember to fix base_a and base_desc + ! + p%precv(1)%base_a => a + p%precv(1)%base_desc => desc_a + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + + + do i=2, iszv ! ! Check on the iprcparm contents: they should be the same ! on all processes. ! - call psb_bcast(ictxt,p%precv(1)%parms) - ! - ! Finest level first; remember to fix base_a and base_desc - ! - p%precv(1)%base_a => a - p%precv(1)%base_desc => desc_a - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - - - do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,p%precv(1)%parms) + call psb_bcast(ictxt,p%precv(i)%parms) + ! + ! Sanity checks on the parameters + ! + if (i= psb_debug_outer_) & - & 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 - ! - if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& - & p%precv(i-1)%base_desc, p%precv(i),info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Init upper level preconditioner') - goto 9999 - endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info - - if (i>2) then - if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit - end if - end do - - if (newsz > 0) then - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) - end if - allocate(t_prec%precv(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-1 - call mld_move_alloc(p%precv(i),t_prec%precv(i),info) - end do - call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info) - do i=newsz+1, iszv - call p%precv(i)%free(info) - end do - call mld_move_alloc(t_prec,p,info) - ! Ignore errors from transfer - info = psb_success_ - ! - ! Restart - iszv = newsz - ! Fix the pointers, but the level 1 should - ! be already OK - do i=2, iszv - 1 - p%precv(i)%base_a => p%precv(i)%ac - p%precv(i)%base_desc => p%precv(i)%desc_ac - p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc - p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc - end do - - - i = iszv - call check_coarse_lev(p%precv(i)) - if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& - & p%precv(i-1)%base_desc, p%precv(i),info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') - goto 9999 - endif end if - end if - do i=1, iszv - ! - ! build the base preconditioner at level i - ! if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Calling mlprcbld at level ',i - call mld_check_def(p%precv(i)%parms%sweeps,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - call mld_check_def(p%precv(i)%parms%sweeps_pre,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - call mld_check_def(p%precv(i)%parms%sweeps_post,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - - if (.not.allocated(p%precv(i)%sm)) then - !! Error: should have called mld_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - if (.not.allocated(p%precv(i)%sm%sv)) then - !! Error: should have called mld_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - ! - ! Test version for beginning of OO stuff. + ! Build the mapping between levels i-1 and i and the matrix + ! at level i ! - call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& - & 'F',info,amold=amold,vmold=vmold) + if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& + & p%precv(i-1)%base_desc, p%precv(i),info) - if ((info == psb_success_).and.(i>1).and.(present(amold))) then - call psb_map_cscnv(p%precv(i)%map,info,mold=amold) - call p%precv(i)%ac%cscnv(info,mold=amold) - end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='One level preconditioner build.') + & a_err='Init upper level preconditioner') goto 9999 endif if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Return from ',i,' call to mlprcbld ',info + + if (i>2) then + if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) exit + end if end do + if (newsz > 0) then + if (me == 0) then + write(debug_unit,*) trim(name),& + &': Warning: aggregates from level ',& + & newsz + write(debug_unit,*) trim(name),& + &': to level ',& + & iszv,' coincide.' + write(debug_unit,*) trim(name),& + &': Number of levels actually used :',newsz + write(debug_unit,*) + end if + allocate(t_prec%precv(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-1 + call mld_move_alloc(p%precv(i),t_prec%precv(i),info) + end do + call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info) + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call mld_move_alloc(t_prec,p,info) + ! Ignore errors from transfer + info = psb_success_ + ! + ! Restart + iszv = newsz + ! Fix the pointers, but the level 1 should + ! be already OK + do i=2, iszv - 1 + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end do + + + i = iszv + call check_coarse_lev(p%precv(i)) + if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& + & p%precv(i-1)%base_desc, p%precv(i),info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') + goto 9999 + endif + end if + end if + + do i=1, iszv + ! + ! build the base preconditioner at level i + ! + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + call mld_check_def(p%precv(i)%parms%sweeps,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%parms%sweeps_pre,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%parms%sweeps_post,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + + if (.not.allocated(p%precv(i)%sm)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + if (.not.allocated(p%precv(i)%sm%sv)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + + ! + ! Test version for beginning of OO stuff. + ! + call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& + & 'F',info,amold=amold,vmold=vmold) + + if ((info == psb_success_).and.(i>1).and.(present(amold))) then + call psb_map_cscnv(p%precv(i)%map,info,mold=amold) + call p%precv(i)%ac%cscnv(info,mold=amold) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='One level preconditioner build.') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + end do + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index 86e5d77b..8f1a949a 100644 --- a/mlprec/impl/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -162,182 +162,182 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + if (iszv > 1) then - ! - ! Build the matrix and the transfer operators corresponding - ! to the remaining levels - ! + ! + ! Build the matrix and the transfer operators corresponding + ! to the remaining levels + ! + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + call psb_bcast(ictxt,p%precv(1)%parms) + ! + ! Finest level first; remember to fix base_a and base_desc + ! + p%precv(1)%base_a => a + p%precv(1)%base_desc => desc_a + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + + + do i=2, iszv ! ! Check on the iprcparm contents: they should be the same ! on all processes. ! - call psb_bcast(ictxt,p%precv(1)%parms) - ! - ! Finest level first; remember to fix base_a and base_desc - ! - p%precv(1)%base_a => a - p%precv(1)%base_desc => desc_a - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - - - do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,p%precv(1)%parms) + call psb_bcast(ictxt,p%precv(i)%parms) + ! + ! Sanity checks on the parameters + ! + if (i= psb_debug_outer_) & - & 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 - ! - if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& - & p%precv(i-1)%base_desc, p%precv(i),info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Init upper level preconditioner') - goto 9999 - endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info - - if (i>2) then - if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit - end if - end do - - if (newsz > 0) then - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) - end if - allocate(t_prec%precv(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-1 - call mld_move_alloc(p%precv(i),t_prec%precv(i),info) - end do - call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info) - do i=newsz+1, iszv - call p%precv(i)%free(info) - end do - call mld_move_alloc(t_prec,p,info) - ! Ignore errors from transfer - info = psb_success_ - ! - ! Restart - iszv = newsz - ! Fix the pointers, but the level 1 should - ! be already OK - do i=2, iszv - 1 - p%precv(i)%base_a => p%precv(i)%ac - p%precv(i)%base_desc => p%precv(i)%desc_ac - p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc - p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc - end do - - - i = iszv - call check_coarse_lev(p%precv(i)) - if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& - & p%precv(i-1)%base_desc, p%precv(i),info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') - goto 9999 - endif end if - end if - do i=1, iszv - ! - ! build the base preconditioner at level i - ! if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Calling mlprcbld at level ',i - call mld_check_def(p%precv(i)%parms%sweeps,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - call mld_check_def(p%precv(i)%parms%sweeps_pre,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - call mld_check_def(p%precv(i)%parms%sweeps_post,& - & 'Jacobi sweeps',1,is_legal_jac_sweeps) - - if (.not.allocated(p%precv(i)%sm)) then - !! Error: should have called mld_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - if (.not.allocated(p%precv(i)%sm%sv)) then - !! Error: should have called mld_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - ! - ! Test version for beginning of OO stuff. + ! Build the mapping between levels i-1 and i and the matrix + ! at level i ! - call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& - & 'F',info,amold=amold,vmold=vmold) + if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& + & p%precv(i-1)%base_desc, p%precv(i),info) - if ((info == psb_success_).and.(i>1).and.(present(amold))) then - call psb_map_cscnv(p%precv(i)%map,info,mold=amold) - call p%precv(i)%ac%cscnv(info,mold=amold) - end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='One level preconditioner build.') + & a_err='Init upper level preconditioner') goto 9999 endif if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Return from ',i,' call to mlprcbld ',info + + if (i>2) then + if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) exit + end if end do + if (newsz > 0) then + if (me == 0) then + write(debug_unit,*) trim(name),& + &': Warning: aggregates from level ',& + & newsz + write(debug_unit,*) trim(name),& + &': to level ',& + & iszv,' coincide.' + write(debug_unit,*) trim(name),& + &': Number of levels actually used :',newsz + write(debug_unit,*) + end if + allocate(t_prec%precv(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-1 + call mld_move_alloc(p%precv(i),t_prec%precv(i),info) + end do + call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info) + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call mld_move_alloc(t_prec,p,info) + ! Ignore errors from transfer + info = psb_success_ + ! + ! Restart + iszv = newsz + ! Fix the pointers, but the level 1 should + ! be already OK + do i=2, iszv - 1 + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end do + + + i = iszv + call check_coarse_lev(p%precv(i)) + if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& + & p%precv(i-1)%base_desc, p%precv(i),info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') + goto 9999 + endif + end if + end if + + do i=1, iszv + ! + ! build the base preconditioner at level i + ! + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + call mld_check_def(p%precv(i)%parms%sweeps,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%parms%sweeps_pre,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%parms%sweeps_post,& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + + if (.not.allocated(p%precv(i)%sm)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + if (.not.allocated(p%precv(i)%sm%sv)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + + ! + ! Test version for beginning of OO stuff. + ! + call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& + & 'F',info,amold=amold,vmold=vmold) + + if ((info == psb_success_).and.(i>1).and.(present(amold))) then + call psb_map_cscnv(p%precv(i)%map,info,mold=amold) + call p%precv(i)%ac%cscnv(info,mold=amold) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='One level preconditioner build.') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + end do + call psb_erractionrestore(err_act) return From e5f9b851ce061fe636133ecd70a934b6e572d776 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 11 Apr 2012 13:03:27 +0000 Subject: [PATCH 03/11] mld2p4-NewML: mlprec/impl/Makefile mlprec/impl/mld_caggrmat_asb.f90 mlprec/impl/mld_caggrmat_minnrg_asb.F90 mlprec/impl/mld_caggrmat_nosmth_asb.F90 mlprec/impl/mld_caggrmat_smth_asb.F90 mlprec/impl/mld_daggrmat_asb.f90 mlprec/impl/mld_daggrmat_minnrg_asb.F90 mlprec/impl/mld_daggrmat_nosmth_asb.F90 mlprec/impl/mld_daggrmat_smth_asb.F90 mlprec/impl/mld_dprecinit.F90 mlprec/impl/mld_dprecset.F90 mlprec/impl/mld_saggrmat_asb.f90 mlprec/impl/mld_saggrmat_minnrg_asb.F90 mlprec/impl/mld_saggrmat_nosmth_asb.F90 mlprec/impl/mld_saggrmat_smth_asb.F90 mlprec/impl/mld_zaggrmat_asb.f90 mlprec/impl/mld_zaggrmat_minnrg_asb.F90 mlprec/impl/mld_zaggrmat_nosmth_asb.F90 mlprec/impl/mld_zaggrmat_smth_asb.F90 mlprec/mld_base_prec_type.F90 mlprec/mld_c_inner_mod.f90 mlprec/mld_d_inner_mod.f90 mlprec/mld_d_prec_type.f90 mlprec/mld_s_inner_mod.f90 mlprec/mld_z_inner_mod.f90 tests/pdegen/runs/ppde.inp 1. New _biz_asb routines 2. New interface declarations. --- mlprec/impl/Makefile | 8 +- mlprec/impl/mld_caggrmat_asb.f90 | 17 +- mlprec/impl/mld_caggrmat_minnrg_asb.F90 | 162 +++++----- mlprec/impl/mld_caggrmat_nosmth_asb.F90 | 141 +++++---- mlprec/impl/mld_caggrmat_smth_asb.F90 | 388 ++++++++---------------- mlprec/impl/mld_daggrmat_asb.f90 | 17 +- mlprec/impl/mld_daggrmat_minnrg_asb.F90 | 166 +++++----- mlprec/impl/mld_daggrmat_nosmth_asb.F90 | 141 +++++---- mlprec/impl/mld_daggrmat_smth_asb.F90 | 388 ++++++++---------------- mlprec/impl/mld_dprecinit.F90 | 1 + mlprec/impl/mld_dprecset.F90 | 5 + mlprec/impl/mld_saggrmat_asb.f90 | 17 +- mlprec/impl/mld_saggrmat_minnrg_asb.F90 | 162 +++++----- mlprec/impl/mld_saggrmat_nosmth_asb.F90 | 141 +++++---- mlprec/impl/mld_saggrmat_smth_asb.F90 | 388 ++++++++---------------- mlprec/impl/mld_zaggrmat_asb.f90 | 17 +- mlprec/impl/mld_zaggrmat_minnrg_asb.F90 | 166 +++++----- mlprec/impl/mld_zaggrmat_nosmth_asb.F90 | 141 +++++---- mlprec/impl/mld_zaggrmat_smth_asb.F90 | 388 ++++++++---------------- mlprec/mld_base_prec_type.F90 | 1 + mlprec/mld_c_inner_mod.f90 | 36 +-- mlprec/mld_d_inner_mod.f90 | 36 +-- mlprec/mld_d_prec_type.f90 | 1 + mlprec/mld_s_inner_mod.f90 | 36 +-- mlprec/mld_z_inner_mod.f90 | 36 +-- tests/pdegen/runs/ppde.inp | 2 +- 26 files changed, 1249 insertions(+), 1753 deletions(-) diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index a4ab4cd3..998aed04 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -7,13 +7,13 @@ HERE=.. FINCLUDES=$(FMFLAG).. $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR) -DMPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o +DMPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o mld_daggrmat_biz_asb.o -SMPFOBJS=mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o mld_saggrmat_minnrg_asb.o +SMPFOBJS=mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o mld_saggrmat_minnrg_asb.o mld_saggrmat_biz_asb.o -ZMPFOBJS=mld_zaggrmat_nosmth_asb.o mld_zaggrmat_smth_asb.o mld_zaggrmat_minnrg_asb.o +ZMPFOBJS=mld_zaggrmat_nosmth_asb.o mld_zaggrmat_smth_asb.o mld_zaggrmat_minnrg_asb.o mld_zaggrmat_biz_asb.o -CMPFOBJS=mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o mld_caggrmat_minnrg_asb.o +CMPFOBJS=mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o mld_caggrmat_minnrg_asb.o mld_caggrmat_biz_asb.o MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS) diff --git a/mlprec/impl/mld_caggrmat_asb.f90 b/mlprec/impl/mld_caggrmat_asb.f90 index 28c67e8d..69cbc9c4 100644 --- a/mlprec/impl/mld_caggrmat_asb.f90 +++ b/mlprec/impl/mld_caggrmat_asb.f90 @@ -113,6 +113,7 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables + type(psb_cspmat_type) :: b, op_prol,op_restr integer :: ictxt,np,me, err_act character(len=20) :: name @@ -128,15 +129,23 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') goto 9999 end if - case(mld_smooth_prol_,mld_biz_prol_) + case(mld_smooth_prol_) - call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + goto 9999 + end if + + case(mld_biz_prol_) + + call mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') goto 9999 @@ -144,7 +153,7 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_min_energy_) - call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') goto 9999 diff --git a/mlprec/impl/mld_caggrmat_minnrg_asb.F90 b/mlprec/impl/mld_caggrmat_minnrg_asb.F90 index 2cfeb59c..00881369 100644 --- a/mlprec/impl/mld_caggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_caggrmat_minnrg_asb.F90 @@ -116,15 +116,15 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_cspmat_type) :: op_prol,op_restr, b ! Local variables - type(psb_cspmat_type) :: b integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt integer :: ictxt,np,me, err_act, icomm character(len=20) :: name - type(psb_cspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp + type(psb_cspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_cspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_cspmat_type) :: dat, datp, datdatp, atmp3 type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo @@ -354,17 +354,17 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*Af)Ptilde + ! op_prol = (I-w*D*Af)Ptilde ! Doing it this way means to consider diag(Af_i) ! ! - call psb_symbmm(af,ptilde,am1,info) + call psb_symbmm(af,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(af,ptilde,am1) + call psb_numbmm(af,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -390,16 +390,16 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*A)Ptilde + ! op_prol = (I-w*D*A)Ptilde ! ! - call psb_symbmm(am3,ptilde,am1,info) + call psb_symbmm(am3,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(am3,ptilde,am1) + call psb_numbmm(am3,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -509,20 +509,20 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call rtilde%mv_from(tmpcoo) call rtilde%cscnv(info,type='csr') - call psb_symbmm(rtilde,atmp,am2,info) - call psb_numbmm(rtilde,atmp,am2) + call psb_symbmm(rtilde,atmp,op_restr,info) + call psb_numbmm(rtilde,atmp,op_restr) ! - ! Now we have to gather the halo of am1, and add it to itself + ! Now we have to gather the halo of op_prol, and add it to itself ! to multiply it by A, ! - call psb_sphalo(am1,desc_a,am4,info,& + call psb_sphalo(op_prol,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if @@ -530,7 +530,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() i=0 @@ -543,21 +543,21 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) end if end do call tmpcoo%set_nzeros(i) - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2' @@ -576,14 +576,13 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) if (info == psb_success_) call am3%free() - call b%mv_to(bcoo) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = am2 x am3') + &a_err='Build b = op_restr x am3') goto 9999 end if @@ -597,6 +596,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_distr_mat_) + call b%mv_to(bcoo) nzl = bcoo%get_nzeros() if (debug_level >= psb_debug_outer_) & @@ -627,29 +627,29 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call p%ac%cscnv(info,type='csr') if (np>1) then - call am1%mv_to(acsr) + call op_prol%mv_to(acsr) nzl = acsr%get_nzeros() call psb_glob_to_loc(acsr%ja(1:nzl),p%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 am1%mv_from(acsr) + call op_prol%mv_from(acsr) endif - call am1%set_ncols(p%desc_ac%get_local_cols()) + call op_prol%set_ncols(p%desc_ac%get_local_cols()) if (np>1) then - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') goto 9999 end if - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') end if - call am2%set_nrows(p%desc_ac%get_local_cols()) + call op_restr%set_nrows(p%desc_ac%get_local_cols()) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -658,47 +658,55 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_repl_mat_) ! ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - nzbr(:) = 0 - nzbr(me+1) = bcoo%get_nzeros() - - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) - 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(bcoo%val,ndx,mpi_complex,tmpcoo%val,nzbr,idisp,& - & mpi_complex,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err=' from mpi_allgatherv') - goto 9999 - end if - - call bcoo%free() - call tmpcoo%fix(info) - call p%ac%mv_from(tmpcoo) - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') + goto 9999 + end if + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + if(info /= psb_success_) goto 9999 +!!$ call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) +!!$ nzbr(:) = 0 +!!$ nzbr(me+1) = bcoo%get_nzeros() +!!$ +!!$ call psb_sum(ictxt,nzbr(1:np)) +!!$ nzac = sum(nzbr) +!!$ if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) +!!$ if (info /= psb_success_) goto 9999 +!!$ +!!$ do ip=1,np +!!$ idispip) = sum(nzbr(1:ip-1)) +!!$ enddo +!!$ ndx = nzbr(me+1) +!!$ +!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_complex,tmpcoo%val,nzbr,idisp,& +!!$ & mpi_complex,icomm,info) +!!$ if (info == psb_success_)& +!!$ & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& +!!$ & psb_mpi_ipk_integer,icomm,info) +!!$ if (info == psb_success_)& +!!$ & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& +!!$ & psb_mpi_ipk_integer,icomm,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err=' from mpi_allgatherv') +!!$ goto 9999 +!!$ end if +!!$ +!!$ call bcoo%free() +!!$ call tmpcoo%fix(info) +!!$ call p%ac%mv_from(tmpcoo) +!!$ call p%ac%cscnv(info,type='csr') +!!$ if(info /= psb_success_) goto 9999 +!!$ +!!$ deallocate(nzbr,idisp,stat=info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') @@ -715,13 +723,13 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => R i.e. restriction operator - ! am1 => P i.e. prolongation operator + ! op_restr => R i.e. restriction operator + ! op_prol => P i.e. prolongation operator ! p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') goto 9999 diff --git a/mlprec/impl/mld_caggrmat_nosmth_asb.F90 b/mlprec/impl/mld_caggrmat_nosmth_asb.F90 index e96b1d55..fcaf10d6 100644 --- a/mlprec/impl/mld_caggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_caggrmat_nosmth_asb.F90 @@ -99,17 +99,17 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_cspmat_type) :: b, op_prol,op_restr ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name - type(psb_cspmat_type) :: b - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) - type(psb_cspmat_type) :: am1,am2 - type(psb_c_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & + type(psb_c_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo, acoo + type(psb_c_csr_sparse_mat) :: acsr1, acsr2 + integer :: debug_level, debug_unit + integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & & naggr, nzt, naggrm1, i name='mld_aggrmat_nosmth_asb' @@ -128,32 +128,19 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - 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 - naggrm1=sum(nlaggr(1:me)) - if (p%parms%coarse_mat == mld_repl_mat_) then - do i=1, nrow - ilaggr(i) = ilaggr(i) + naggrm1 - end do - call psb_halo(ilaggr,desc_a,info) - end if + do i=1, nrow + ilaggr(i) = ilaggr(i) + naggrm1 + end do + call psb_halo(ilaggr,desc_a,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') goto 9999 end if - if (p%parms%coarse_mat == mld_repl_mat_) then - call acoo1%allocate(ncol,ntaggr,ncol) - else - call acoo1%allocate(ncol,naggr,ncol) - end if + call acoo1%allocate(ncol,ntaggr,ncol) do i=1,nrow acoo1%val(i) = cone @@ -165,10 +152,13 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call acoo1%set_nzeros(nrow) call acoo1%set_asb() call acoo1%fix(info) - call acoo1%transp(acoo2) - call a%csclip(bcoo,info,jmax=nrow) + call op_prol%mv_from(acoo1) + call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call op_prol%transp(op_restr) + + call a%csclip(bcoo,info,jmax=nrow) nzt = bcoo%get_nzeros() do i=1, nzt @@ -181,6 +171,8 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call bcoo%fix(info) + call b%mv_from(bcoo) + if (p%parms%coarse_mat == mld_repl_mat_) then call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) @@ -189,55 +181,74 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') goto 9999 end if + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + if(info /= psb_success_) goto 9999 - nzbr(:) = 0 - nzbr(me+1) = nzt - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - - call ac_coo%allocate(ntaggr,ntaggr,nzac) + else if (p%parms%coarse_mat == mld_distr_mat_) then - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) + nzl = b%get_nzeros() + call b%mv_to(bcoo) - call mpi_allgatherv(bcoo%val,ndx,mpi_complex,ac_coo%val,nzbr,idisp,& - & mpi_complex,icomm,minfo) - call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if(info /= psb_success_) then - info=-1 - call psb_errpush(info,name) + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 end if - call ac_coo%set_nzeros(nzac) - call ac_coo%set_dupl(psb_dupl_add_) - call ac_coo%fix(info) - call p%ac%mv_from(ac_coo) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - else if (p%parms%coarse_mat == mld_distr_mat_) then + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - call p%ac%mv_from(bcoo) - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') + 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),p%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(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 - + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' else info = psb_err_internal_error_ call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') goto 9999 end if - call bcoo%free() - - deallocate(nzbr,idisp) call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) if(info /= psb_success_) then @@ -245,20 +256,16 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - call am1%mv_from(acoo1) - call am1%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo2) - if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator ! if (info == psb_success_) & & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') goto 9999 diff --git a/mlprec/impl/mld_caggrmat_smth_asb.F90 b/mlprec/impl/mld_caggrmat_smth_asb.F90 index 7ec9e44a..75ef464d 100644 --- a/mlprec/impl/mld_caggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_caggrmat_smth_asb.F90 @@ -61,11 +61,6 @@ ! according to the value of p%parms%aggr_omega_alg, specified by the user ! through mld_cprecinit and mld_zprecset. ! -! This routine can also build A_C according to a "bizarre" aggregation algorithm, -! using a "naive" prolongator proposed by the authors of MLD2P4. However, this -! prolongator still requires a deep analysis and testing and its use is not -! recommended. -! ! The coarse-level matrix A_C is distributed among the parallel processes or ! replicated on each of them, according to the value of p%parms%coarse_mat, ! specified by the user through mld_cprecinit and mld_zprecset. @@ -116,20 +111,19 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_cspmat_type) :: op_prol, op_restr, b ! Local variables - type(psb_cspmat_type) :: b - integer, allocatable :: nzbr(:), idisp(:) - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw integer ::ictxt, np, me, err_act character(len=20) :: name - type(psb_cspmat_type) :: am1,am2, am3, am4 + type(psb_cspmat_type) :: am3, am4 type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde complex(psb_spk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) - logical :: ml_global_nmb, filter_mat + logical :: filter_mat integer :: debug_level, debug_unit integer, parameter :: ncmax=16 real(psb_spk_) :: anorm, omega, tmp, dg, theta @@ -155,29 +149,16 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - 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 - naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& - & ( (p%parms%aggr_kind == mld_biz_prol_).and.& - & (p%parms%coarse_mat == mld_repl_mat_)) ) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) - if (ml_global_nmb) then - ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 - call psb_halo(ilaggr,desc_a,info) + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 end if ! naggr: number of local aggregates @@ -202,32 +183,22 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - if (ml_global_nmb) then - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - acoo%val(i) = cone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(ncol) - else - call acoo%allocate(ncol,naggr,ncol) - do i=1,nrow - acoo%val(i) = cone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(nrow) - endif + call acoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + acoo%val(i) = cone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) + end do + call acoo%set_nzeros(ncol) call acoo%set_dupl(psb_dupl_add_) - + call ptilde%mv_from_coo(acoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ' Initial copies sone.' - + if (filter_mat) then ! ! Build the filtered matrix Af from A @@ -285,35 +256,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (p%parms%aggr_eig == mld_max_norm_) then - if (p%parms%aggr_kind == mld_biz_prol_) then - - ! - ! This only works with CSR - ! - anorm = szero - dg = sone - nrw = acsr3%get_nrows() - do i=1, nrw - tmp = szero - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) <= nrw) then - tmp = tmp + abs(acsr3%val(j)) - endif - if (acsr3%ja(j) == i ) then - dg = abs(acsr3%val(j)) - end if - end do - anorm = max(anorm,tmp/dg) - enddo - - call psb_amx(ictxt,anorm) - else - anorm = acsr3%csnmi() - endif - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') - goto 9999 - end if + anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) p%parms%aggr_omega_val = omega @@ -368,7 +311,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' - + else ! ! Build the smoothed prolongator using the original matrix @@ -409,76 +352,64 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call ptilde%free() call acsr1%set_dupl(psb_dupl_add_) - call am1%mv_from(acsr1) - if (ml_global_nmb) then - ! - ! Now we have to gather the halo of am1, and add it to itself - ! to multiply it by A, - ! - call psb_sphalo(am1,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) - if (info == psb_success_) call am4%free() - else - call psb_rwextd(ncol,am1,info) - endif + call op_prol%mv_from(acsr1) + ! + ! Now we have to gather the halo of op_prol, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(op_prol,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ - if (p%parms%aggr_kind == mld_smooth_prol_) then - call am1%transp(am2) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - i=0 - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then - i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) - end if - end do - call acoo%set_nzeros(i) - call acoo%trim() - call am2%mv_from(acoo) - call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') - goto 9999 + call op_prol%transp(op_restr) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) + ! + do k=1, nzl + if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then + i = i+1 + acoo%val(i) = acoo%val(k) + acoo%ia(i) = acoo%ia(k) + acoo%ja(i) = acoo%ja(k) end if - else - call am1%transp(am2) - endif + end do + call acoo%set_nzeros(i) + call acoo%trim() + call op_restr%mv_from(acoo) + call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') + goto 9999 + end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - if (p%parms%aggr_kind == mld_smooth_prol_) then - ! am2 = ((i-wDA)Ptilde)^T - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - else if (p%parms%aggr_kind == mld_biz_prol_) then - call psb_rwextd(ncol,am3,info) - endif + ! op_restr = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') goto 9999 @@ -488,160 +419,93 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) if (info == psb_success_) call am3%free() if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') goto 9999 end if - select case(p%parms%aggr_kind) - - case(mld_smooth_prol_) + select case(p%parms%coarse_mat) - select case(p%parms%coarse_mat) + case(mld_distr_mat_) - case(mld_distr_mat_) + nzl = b%get_nzeros() + call b%mv_to(bcoo) - nzac = b%get_nzeros() - nzl = nzac - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%ac%set_asb() - - if (info == psb_success_) deallocate(nzbr,idisp,stat=info) - 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 am1%mv_to(acsr1) - nzl = acsr1%get_nzeros() - call psb_glob_to_loc(acsr1%ja(1:nzl),p%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 am1%mv_from(acsr1) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%cscnv(info,type='coo',dupl=psb_dupl_add_) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo) - if (info == psb_success_) call am2%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - - if (info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 - end select - - - case(mld_biz_prol_) + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - select case(p%parms%coarse_mat) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - case(mld_distr_mat_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') + goto 9999 + end if - call psb_move_alloc(b,p%ac,info) - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%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 - - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + call op_prol%mv_from(acsr1) + endif + call op_prol%set_ncols(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + if (info == psb_success_) call op_restr%cscnv(info,type='csr') if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') goto 9999 end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 + end if + call op_restr%set_nrows(p%desc_ac%get_local_cols()) - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + if (info /= psb_success_) goto 9999 case default info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') goto 9999 - end select call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) @@ -652,14 +516,14 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator ! - + p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') goto 9999 diff --git a/mlprec/impl/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 index 53df4f98..7024b969 100644 --- a/mlprec/impl/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -113,6 +113,7 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables + type(psb_dspmat_type) :: b, op_prol,op_restr integer :: ictxt,np,me, err_act character(len=20) :: name @@ -128,15 +129,23 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') goto 9999 end if - case(mld_smooth_prol_,mld_biz_prol_) + case(mld_smooth_prol_) - call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + goto 9999 + end if + + case(mld_biz_prol_) + + call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') goto 9999 @@ -144,7 +153,7 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_min_energy_) - call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') goto 9999 diff --git a/mlprec/impl/mld_daggrmat_minnrg_asb.F90 b/mlprec/impl/mld_daggrmat_minnrg_asb.F90 index 4b04e3bb..bb5ae741 100644 --- a/mlprec/impl/mld_daggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.F90 @@ -116,15 +116,15 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_dspmat_type) :: op_prol,op_restr, b ! Local variables - type(psb_dspmat_type) :: b integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt integer :: ictxt,np,me, err_act, icomm character(len=20) :: name - type(psb_dspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp + type(psb_dspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_dspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_dspmat_type) :: dat, datp, datdatp, atmp3 type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo @@ -280,7 +280,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call am3%mv_to(acsr3) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = cmplx(dzero,dzero) do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -354,17 +354,17 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*Af)Ptilde + ! op_prol = (I-w*D*Af)Ptilde ! Doing it this way means to consider diag(Af_i) ! ! - call psb_symbmm(af,ptilde,am1,info) + call psb_symbmm(af,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(af,ptilde,am1) + call psb_numbmm(af,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -390,16 +390,16 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*A)Ptilde + ! op_prol = (I-w*D*A)Ptilde ! ! - call psb_symbmm(am3,ptilde,am1,info) + call psb_symbmm(am3,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(am3,ptilde,am1) + call psb_numbmm(am3,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -458,7 +458,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) omp = omp/oden ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = cmplx(dzero,dzero) do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -509,20 +509,20 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call rtilde%mv_from(tmpcoo) call rtilde%cscnv(info,type='csr') - call psb_symbmm(rtilde,atmp,am2,info) - call psb_numbmm(rtilde,atmp,am2) + call psb_symbmm(rtilde,atmp,op_restr,info) + call psb_numbmm(rtilde,atmp,op_restr) ! - ! Now we have to gather the halo of am1, and add it to itself + ! Now we have to gather the halo of op_prol, and add it to itself ! to multiply it by A, ! - call psb_sphalo(am1,desc_a,am4,info,& + call psb_sphalo(op_prol,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if @@ -530,7 +530,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() i=0 @@ -543,21 +543,21 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) end if end do call tmpcoo%set_nzeros(i) - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2' @@ -576,14 +576,13 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) if (info == psb_success_) call am3%free() - call b%mv_to(bcoo) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = am2 x am3') + &a_err='Build b = op_restr x am3') goto 9999 end if @@ -597,6 +596,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_distr_mat_) + call b%mv_to(bcoo) nzl = bcoo%get_nzeros() if (debug_level >= psb_debug_outer_) & @@ -627,29 +627,29 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call p%ac%cscnv(info,type='csr') if (np>1) then - call am1%mv_to(acsr) + call op_prol%mv_to(acsr) nzl = acsr%get_nzeros() call psb_glob_to_loc(acsr%ja(1:nzl),p%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 am1%mv_from(acsr) + call op_prol%mv_from(acsr) endif - call am1%set_ncols(p%desc_ac%get_local_cols()) + call op_prol%set_ncols(p%desc_ac%get_local_cols()) if (np>1) then - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') goto 9999 end if - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') end if - call am2%set_nrows(p%desc_ac%get_local_cols()) + call op_restr%set_nrows(p%desc_ac%get_local_cols()) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -658,47 +658,55 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_repl_mat_) ! ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - nzbr(:) = 0 - nzbr(me+1) = bcoo%get_nzeros() - - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) - 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(bcoo%val,ndx,mpi_double_precision,tmpcoo%val,nzbr,idisp,& - & mpi_double_precision,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err=' from mpi_allgatherv') - goto 9999 - end if - - call bcoo%free() - call tmpcoo%fix(info) - call p%ac%mv_from(tmpcoo) - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') + goto 9999 + end if + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + if(info /= psb_success_) goto 9999 +!!$ call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) +!!$ nzbr(:) = 0 +!!$ nzbr(me+1) = bcoo%get_nzeros() +!!$ +!!$ call psb_sum(ictxt,nzbr(1:np)) +!!$ nzac = sum(nzbr) +!!$ if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) +!!$ if (info /= psb_success_) goto 9999 +!!$ +!!$ do ip=1,np +!!$ idispip) = sum(nzbr(1:ip-1)) +!!$ enddo +!!$ ndx = nzbr(me+1) +!!$ +!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,tmpcoo%val,nzbr,idisp,& +!!$ & mpi_double_precision,icomm,info) +!!$ if (info == psb_success_)& +!!$ & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& +!!$ & psb_mpi_ipk_integer,icomm,info) +!!$ if (info == psb_success_)& +!!$ & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& +!!$ & psb_mpi_ipk_integer,icomm,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err=' from mpi_allgatherv') +!!$ goto 9999 +!!$ end if +!!$ +!!$ call bcoo%free() +!!$ call tmpcoo%fix(info) +!!$ call p%ac%mv_from(tmpcoo) +!!$ call p%ac%cscnv(info,type='csr') +!!$ if(info /= psb_success_) goto 9999 +!!$ +!!$ deallocate(nzbr,idisp,stat=info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') @@ -715,13 +723,13 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => R i.e. restriction operator - ! am1 => P i.e. prolongation operator + ! op_restr => R i.e. restriction operator + ! op_prol => P i.e. prolongation operator ! p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') goto 9999 diff --git a/mlprec/impl/mld_daggrmat_nosmth_asb.F90 b/mlprec/impl/mld_daggrmat_nosmth_asb.F90 index 715f3601..d161bc04 100644 --- a/mlprec/impl/mld_daggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_daggrmat_nosmth_asb.F90 @@ -99,17 +99,17 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_dspmat_type) :: b, op_prol,op_restr ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name - type(psb_dspmat_type) :: b - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) - type(psb_dspmat_type) :: am1,am2 - type(psb_d_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & + type(psb_d_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo, acoo + type(psb_d_csr_sparse_mat) :: acsr1, acsr2 + integer :: debug_level, debug_unit + integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & & naggr, nzt, naggrm1, i name='mld_aggrmat_nosmth_asb' @@ -128,32 +128,19 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - 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 - naggrm1=sum(nlaggr(1:me)) - if (p%parms%coarse_mat == mld_repl_mat_) then - do i=1, nrow - ilaggr(i) = ilaggr(i) + naggrm1 - end do - call psb_halo(ilaggr,desc_a,info) - end if + do i=1, nrow + ilaggr(i) = ilaggr(i) + naggrm1 + end do + call psb_halo(ilaggr,desc_a,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') goto 9999 end if - if (p%parms%coarse_mat == mld_repl_mat_) then - call acoo1%allocate(ncol,ntaggr,ncol) - else - call acoo1%allocate(ncol,naggr,ncol) - end if + call acoo1%allocate(ncol,ntaggr,ncol) do i=1,nrow acoo1%val(i) = done @@ -165,10 +152,13 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call acoo1%set_nzeros(nrow) call acoo1%set_asb() call acoo1%fix(info) - call acoo1%transp(acoo2) - call a%csclip(bcoo,info,jmax=nrow) + call op_prol%mv_from(acoo1) + call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call op_prol%transp(op_restr) + + call a%csclip(bcoo,info,jmax=nrow) nzt = bcoo%get_nzeros() do i=1, nzt @@ -181,6 +171,8 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call bcoo%fix(info) + call b%mv_from(bcoo) + if (p%parms%coarse_mat == mld_repl_mat_) then call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) @@ -189,55 +181,74 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') goto 9999 end if + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + if(info /= psb_success_) goto 9999 - nzbr(:) = 0 - nzbr(me+1) = nzt - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - - call ac_coo%allocate(ntaggr,ntaggr,nzac) + else if (p%parms%coarse_mat == mld_distr_mat_) then - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) + nzl = b%get_nzeros() + call b%mv_to(bcoo) - call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,ac_coo%val,nzbr,idisp,& - & mpi_double_precision,icomm,minfo) - call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if(info /= psb_success_) then - info=-1 - call psb_errpush(info,name) + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 end if - call ac_coo%set_nzeros(nzac) - call ac_coo%set_dupl(psb_dupl_add_) - call ac_coo%fix(info) - call p%ac%mv_from(ac_coo) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - else if (p%parms%coarse_mat == mld_distr_mat_) then + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - call p%ac%mv_from(bcoo) - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') + 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),p%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(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 - + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' else info = psb_err_internal_error_ call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') goto 9999 end if - call bcoo%free() - - deallocate(nzbr,idisp) call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) if(info /= psb_success_) then @@ -245,20 +256,16 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - call am1%mv_from(acoo1) - call am1%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo2) - if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator ! if (info == psb_success_) & & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') goto 9999 diff --git a/mlprec/impl/mld_daggrmat_smth_asb.F90 b/mlprec/impl/mld_daggrmat_smth_asb.F90 index fb917201..af0c1fb4 100644 --- a/mlprec/impl/mld_daggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_daggrmat_smth_asb.F90 @@ -61,11 +61,6 @@ ! according to the value of p%parms%aggr_omega_alg, specified by the user ! through mld_dprecinit and mld_zprecset. ! -! This routine can also build A_C according to a "bizarre" aggregation algorithm, -! using a "naive" prolongator proposed by the authors of MLD2P4. However, this -! prolongator still requires a deep analysis and testing and its use is not -! recommended. -! ! The coarse-level matrix A_C is distributed among the parallel processes or ! replicated on each of them, according to the value of p%parms%coarse_mat, ! specified by the user through mld_dprecinit and mld_zprecset. @@ -116,20 +111,19 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_dspmat_type) :: op_prol, op_restr, b ! Local variables - type(psb_dspmat_type) :: b - integer, allocatable :: nzbr(:), idisp(:) - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw integer ::ictxt, np, me, err_act character(len=20) :: name - type(psb_dspmat_type) :: am1,am2, am3, am4 + type(psb_dspmat_type) :: am3, am4 type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde real(psb_dpk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) - logical :: ml_global_nmb, filter_mat + logical :: filter_mat integer :: debug_level, debug_unit integer, parameter :: ncmax=16 real(psb_dpk_) :: anorm, omega, tmp, dg, theta @@ -155,29 +149,16 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - 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 - naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& - & ( (p%parms%aggr_kind == mld_biz_prol_).and.& - & (p%parms%coarse_mat == mld_repl_mat_)) ) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) - if (ml_global_nmb) then - ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 - call psb_halo(ilaggr,desc_a,info) + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 end if ! naggr: number of local aggregates @@ -202,32 +183,22 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - if (ml_global_nmb) then - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - acoo%val(i) = done - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(ncol) - else - call acoo%allocate(ncol,naggr,ncol) - do i=1,nrow - acoo%val(i) = done - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(nrow) - endif + call acoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + acoo%val(i) = done + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) + end do + call acoo%set_nzeros(ncol) call acoo%set_dupl(psb_dupl_add_) - + call ptilde%mv_from_coo(acoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ' Initial copies sone.' - + if (filter_mat) then ! ! Build the filtered matrix Af from A @@ -285,35 +256,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (p%parms%aggr_eig == mld_max_norm_) then - if (p%parms%aggr_kind == mld_biz_prol_) then - - ! - ! This only works with CSR - ! - anorm = dzero - dg = done - nrw = acsr3%get_nrows() - do i=1, nrw - tmp = szero - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) <= nrw) then - tmp = tmp + abs(acsr3%val(j)) - endif - if (acsr3%ja(j) == i ) then - dg = abs(acsr3%val(j)) - end if - end do - anorm = max(anorm,tmp/dg) - enddo - - call psb_amx(ictxt,anorm) - else - anorm = acsr3%csnmi() - endif - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') - goto 9999 - end if + anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) p%parms%aggr_omega_val = omega @@ -368,7 +311,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' - + else ! ! Build the smoothed prolongator using the original matrix @@ -409,76 +352,64 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call ptilde%free() call acsr1%set_dupl(psb_dupl_add_) - call am1%mv_from(acsr1) - if (ml_global_nmb) then - ! - ! Now we have to gather the halo of am1, and add it to itself - ! to multiply it by A, - ! - call psb_sphalo(am1,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) - if (info == psb_success_) call am4%free() - else - call psb_rwextd(ncol,am1,info) - endif + call op_prol%mv_from(acsr1) + ! + ! Now we have to gather the halo of op_prol, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(op_prol,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ - if (p%parms%aggr_kind == mld_smooth_prol_) then - call am1%transp(am2) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - i=0 - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then - i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) - end if - end do - call acoo%set_nzeros(i) - call acoo%trim() - call am2%mv_from(acoo) - call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') - goto 9999 + call op_prol%transp(op_restr) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) + ! + do k=1, nzl + if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then + i = i+1 + acoo%val(i) = acoo%val(k) + acoo%ia(i) = acoo%ia(k) + acoo%ja(i) = acoo%ja(k) end if - else - call am1%transp(am2) - endif + end do + call acoo%set_nzeros(i) + call acoo%trim() + call op_restr%mv_from(acoo) + call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') + goto 9999 + end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - if (p%parms%aggr_kind == mld_smooth_prol_) then - ! am2 = ((i-wDA)Ptilde)^T - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - else if (p%parms%aggr_kind == mld_biz_prol_) then - call psb_rwextd(ncol,am3,info) - endif + ! op_restr = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') goto 9999 @@ -488,160 +419,93 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) if (info == psb_success_) call am3%free() if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') goto 9999 end if - select case(p%parms%aggr_kind) - - case(mld_smooth_prol_) + select case(p%parms%coarse_mat) - select case(p%parms%coarse_mat) + case(mld_distr_mat_) - case(mld_distr_mat_) + nzl = b%get_nzeros() + call b%mv_to(bcoo) - nzac = b%get_nzeros() - nzl = nzac - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%ac%set_asb() - - if (info == psb_success_) deallocate(nzbr,idisp,stat=info) - 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 am1%mv_to(acsr1) - nzl = acsr1%get_nzeros() - call psb_glob_to_loc(acsr1%ja(1:nzl),p%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 am1%mv_from(acsr1) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%cscnv(info,type='coo',dupl=psb_dupl_add_) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo) - if (info == psb_success_) call am2%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - - if (info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 - end select - - - case(mld_biz_prol_) + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - select case(p%parms%coarse_mat) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - case(mld_distr_mat_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') + goto 9999 + end if - call psb_move_alloc(b,p%ac,info) - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%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 - - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + call op_prol%mv_from(acsr1) + endif + call op_prol%set_ncols(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + if (info == psb_success_) call op_restr%cscnv(info,type='csr') if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') goto 9999 end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 + end if + call op_restr%set_nrows(p%desc_ac%get_local_cols()) - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + if (info /= psb_success_) goto 9999 case default info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') goto 9999 - end select call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) @@ -652,14 +516,14 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator ! - + p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') goto 9999 diff --git a/mlprec/impl/mld_dprecinit.F90 b/mlprec/impl/mld_dprecinit.F90 index be4f1680..fc1571ca 100644 --- a/mlprec/impl/mld_dprecinit.F90 +++ b/mlprec/impl/mld_dprecinit.F90 @@ -125,6 +125,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev) ! Do we want to do something? endif endif + p%coarse_aggr_size = -1 select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NOPREC','NONE') diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 28a649fb..5fbcd84d 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -129,6 +129,11 @@ subroutine mld_dprecseti(p,what,val,info,ilev) return endif + if (what == mld_coarse_aggr_size_) then + p%coarse_aggr_size = max(val,-1) + return + end if + ! ! Set preconditioner parameters at level ilev. ! diff --git a/mlprec/impl/mld_saggrmat_asb.f90 b/mlprec/impl/mld_saggrmat_asb.f90 index 526d5cbd..9ce3b701 100644 --- a/mlprec/impl/mld_saggrmat_asb.f90 +++ b/mlprec/impl/mld_saggrmat_asb.f90 @@ -113,6 +113,7 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables + type(psb_sspmat_type) :: b, op_prol,op_restr integer :: ictxt,np,me, err_act character(len=20) :: name @@ -128,15 +129,23 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') goto 9999 end if - case(mld_smooth_prol_,mld_biz_prol_) + case(mld_smooth_prol_) - call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + goto 9999 + end if + + case(mld_biz_prol_) + + call mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') goto 9999 @@ -144,7 +153,7 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_min_energy_) - call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') goto 9999 diff --git a/mlprec/impl/mld_saggrmat_minnrg_asb.F90 b/mlprec/impl/mld_saggrmat_minnrg_asb.F90 index d3829933..f35a9199 100644 --- a/mlprec/impl/mld_saggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_saggrmat_minnrg_asb.F90 @@ -116,15 +116,15 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_sspmat_type) :: op_prol,op_restr, b ! Local variables - type(psb_sspmat_type) :: b integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt integer :: ictxt,np,me, err_act, icomm character(len=20) :: name - type(psb_sspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp + type(psb_sspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_sspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_sspmat_type) :: dat, datp, datdatp, atmp3 type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo @@ -354,17 +354,17 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*Af)Ptilde + ! op_prol = (I-w*D*Af)Ptilde ! Doing it this way means to consider diag(Af_i) ! ! - call psb_symbmm(af,ptilde,am1,info) + call psb_symbmm(af,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(af,ptilde,am1) + call psb_numbmm(af,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -390,16 +390,16 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*A)Ptilde + ! op_prol = (I-w*D*A)Ptilde ! ! - call psb_symbmm(am3,ptilde,am1,info) + call psb_symbmm(am3,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(am3,ptilde,am1) + call psb_numbmm(am3,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -509,20 +509,20 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call rtilde%mv_from(tmpcoo) call rtilde%cscnv(info,type='csr') - call psb_symbmm(rtilde,atmp,am2,info) - call psb_numbmm(rtilde,atmp,am2) + call psb_symbmm(rtilde,atmp,op_restr,info) + call psb_numbmm(rtilde,atmp,op_restr) ! - ! Now we have to gather the halo of am1, and add it to itself + ! Now we have to gather the halo of op_prol, and add it to itself ! to multiply it by A, ! - call psb_sphalo(am1,desc_a,am4,info,& + call psb_sphalo(op_prol,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if @@ -530,7 +530,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() i=0 @@ -543,21 +543,21 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) end if end do call tmpcoo%set_nzeros(i) - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2' @@ -576,14 +576,13 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) if (info == psb_success_) call am3%free() - call b%mv_to(bcoo) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = am2 x am3') + &a_err='Build b = op_restr x am3') goto 9999 end if @@ -597,6 +596,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_distr_mat_) + call b%mv_to(bcoo) nzl = bcoo%get_nzeros() if (debug_level >= psb_debug_outer_) & @@ -627,29 +627,29 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call p%ac%cscnv(info,type='csr') if (np>1) then - call am1%mv_to(acsr) + call op_prol%mv_to(acsr) nzl = acsr%get_nzeros() call psb_glob_to_loc(acsr%ja(1:nzl),p%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 am1%mv_from(acsr) + call op_prol%mv_from(acsr) endif - call am1%set_ncols(p%desc_ac%get_local_cols()) + call op_prol%set_ncols(p%desc_ac%get_local_cols()) if (np>1) then - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') goto 9999 end if - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') end if - call am2%set_nrows(p%desc_ac%get_local_cols()) + call op_restr%set_nrows(p%desc_ac%get_local_cols()) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -658,47 +658,55 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_repl_mat_) ! ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - nzbr(:) = 0 - nzbr(me+1) = bcoo%get_nzeros() - - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) - 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(bcoo%val,ndx,mpi_real,tmpcoo%val,nzbr,idisp,& - & mpi_real,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err=' from mpi_allgatherv') - goto 9999 - end if - - call bcoo%free() - call tmpcoo%fix(info) - call p%ac%mv_from(tmpcoo) - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') + goto 9999 + end if + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + if(info /= psb_success_) goto 9999 +!!$ call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) +!!$ nzbr(:) = 0 +!!$ nzbr(me+1) = bcoo%get_nzeros() +!!$ +!!$ call psb_sum(ictxt,nzbr(1:np)) +!!$ nzac = sum(nzbr) +!!$ if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) +!!$ if (info /= psb_success_) goto 9999 +!!$ +!!$ do ip=1,np +!!$ idispip) = sum(nzbr(1:ip-1)) +!!$ enddo +!!$ ndx = nzbr(me+1) +!!$ +!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_real,tmpcoo%val,nzbr,idisp,& +!!$ & mpi_real,icomm,info) +!!$ if (info == psb_success_)& +!!$ & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& +!!$ & psb_mpi_ipk_integer,icomm,info) +!!$ if (info == psb_success_)& +!!$ & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& +!!$ & psb_mpi_ipk_integer,icomm,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err=' from mpi_allgatherv') +!!$ goto 9999 +!!$ end if +!!$ +!!$ call bcoo%free() +!!$ call tmpcoo%fix(info) +!!$ call p%ac%mv_from(tmpcoo) +!!$ call p%ac%cscnv(info,type='csr') +!!$ if(info /= psb_success_) goto 9999 +!!$ +!!$ deallocate(nzbr,idisp,stat=info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') @@ -715,13 +723,13 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => R i.e. restriction operator - ! am1 => P i.e. prolongation operator + ! op_restr => R i.e. restriction operator + ! op_prol => P i.e. prolongation operator ! p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') goto 9999 diff --git a/mlprec/impl/mld_saggrmat_nosmth_asb.F90 b/mlprec/impl/mld_saggrmat_nosmth_asb.F90 index 86995791..6f3eb3b6 100644 --- a/mlprec/impl/mld_saggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_saggrmat_nosmth_asb.F90 @@ -99,17 +99,17 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_sspmat_type) :: b, op_prol,op_restr ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name - type(psb_sspmat_type) :: b - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) - type(psb_sspmat_type) :: am1,am2 - type(psb_s_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & + type(psb_s_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo, acoo + type(psb_s_csr_sparse_mat) :: acsr1, acsr2 + integer :: debug_level, debug_unit + integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & & naggr, nzt, naggrm1, i name='mld_aggrmat_nosmth_asb' @@ -128,32 +128,19 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - 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 - naggrm1=sum(nlaggr(1:me)) - if (p%parms%coarse_mat == mld_repl_mat_) then - do i=1, nrow - ilaggr(i) = ilaggr(i) + naggrm1 - end do - call psb_halo(ilaggr,desc_a,info) - end if + do i=1, nrow + ilaggr(i) = ilaggr(i) + naggrm1 + end do + call psb_halo(ilaggr,desc_a,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') goto 9999 end if - if (p%parms%coarse_mat == mld_repl_mat_) then - call acoo1%allocate(ncol,ntaggr,ncol) - else - call acoo1%allocate(ncol,naggr,ncol) - end if + call acoo1%allocate(ncol,ntaggr,ncol) do i=1,nrow acoo1%val(i) = sone @@ -165,10 +152,13 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call acoo1%set_nzeros(nrow) call acoo1%set_asb() call acoo1%fix(info) - call acoo1%transp(acoo2) - call a%csclip(bcoo,info,jmax=nrow) + call op_prol%mv_from(acoo1) + call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call op_prol%transp(op_restr) + + call a%csclip(bcoo,info,jmax=nrow) nzt = bcoo%get_nzeros() do i=1, nzt @@ -181,6 +171,8 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call bcoo%fix(info) + call b%mv_from(bcoo) + if (p%parms%coarse_mat == mld_repl_mat_) then call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) @@ -189,55 +181,74 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') goto 9999 end if + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + if(info /= psb_success_) goto 9999 - nzbr(:) = 0 - nzbr(me+1) = nzt - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - - call ac_coo%allocate(ntaggr,ntaggr,nzac) + else if (p%parms%coarse_mat == mld_distr_mat_) then - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) + nzl = b%get_nzeros() + call b%mv_to(bcoo) - call mpi_allgatherv(bcoo%val,ndx,mpi_real,ac_coo%val,nzbr,idisp,& - & mpi_real,icomm,minfo) - call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if(info /= psb_success_) then - info=-1 - call psb_errpush(info,name) + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 end if - call ac_coo%set_nzeros(nzac) - call ac_coo%set_dupl(psb_dupl_add_) - call ac_coo%fix(info) - call p%ac%mv_from(ac_coo) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - else if (p%parms%coarse_mat == mld_distr_mat_) then + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - call p%ac%mv_from(bcoo) - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') + 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),p%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(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 - + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' else info = psb_err_internal_error_ call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') goto 9999 end if - call bcoo%free() - - deallocate(nzbr,idisp) call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) if(info /= psb_success_) then @@ -245,20 +256,16 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - call am1%mv_from(acoo1) - call am1%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo2) - if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator ! if (info == psb_success_) & & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') goto 9999 diff --git a/mlprec/impl/mld_saggrmat_smth_asb.F90 b/mlprec/impl/mld_saggrmat_smth_asb.F90 index 47519967..76a44eb2 100644 --- a/mlprec/impl/mld_saggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_saggrmat_smth_asb.F90 @@ -61,11 +61,6 @@ ! according to the value of p%parms%aggr_omega_alg, specified by the user ! through mld_sprecinit and mld_zprecset. ! -! This routine can also build A_C according to a "bizarre" aggregation algorithm, -! using a "naive" prolongator proposed by the authors of MLD2P4. However, this -! prolongator still requires a deep analysis and testing and its use is not -! recommended. -! ! The coarse-level matrix A_C is distributed among the parallel processes or ! replicated on each of them, according to the value of p%parms%coarse_mat, ! specified by the user through mld_sprecinit and mld_zprecset. @@ -116,20 +111,19 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_sspmat_type) :: op_prol, op_restr, b ! Local variables - type(psb_sspmat_type) :: b - integer, allocatable :: nzbr(:), idisp(:) - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw integer ::ictxt, np, me, err_act character(len=20) :: name - type(psb_sspmat_type) :: am1,am2, am3, am4 + type(psb_sspmat_type) :: am3, am4 type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde real(psb_spk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) - logical :: ml_global_nmb, filter_mat + logical :: filter_mat integer :: debug_level, debug_unit integer, parameter :: ncmax=16 real(psb_spk_) :: anorm, omega, tmp, dg, theta @@ -155,29 +149,16 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - 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 - naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& - & ( (p%parms%aggr_kind == mld_biz_prol_).and.& - & (p%parms%coarse_mat == mld_repl_mat_)) ) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) - if (ml_global_nmb) then - ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 - call psb_halo(ilaggr,desc_a,info) + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 end if ! naggr: number of local aggregates @@ -202,32 +183,22 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - if (ml_global_nmb) then - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - acoo%val(i) = sone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(ncol) - else - call acoo%allocate(ncol,naggr,ncol) - do i=1,nrow - acoo%val(i) = sone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(nrow) - endif + call acoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + acoo%val(i) = sone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) + end do + call acoo%set_nzeros(ncol) call acoo%set_dupl(psb_dupl_add_) - + call ptilde%mv_from_coo(acoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ' Initial copies sone.' - + if (filter_mat) then ! ! Build the filtered matrix Af from A @@ -285,35 +256,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (p%parms%aggr_eig == mld_max_norm_) then - if (p%parms%aggr_kind == mld_biz_prol_) then - - ! - ! This only works with CSR - ! - anorm = szero - dg = sone - nrw = acsr3%get_nrows() - do i=1, nrw - tmp = szero - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) <= nrw) then - tmp = tmp + abs(acsr3%val(j)) - endif - if (acsr3%ja(j) == i ) then - dg = abs(acsr3%val(j)) - end if - end do - anorm = max(anorm,tmp/dg) - enddo - - call psb_amx(ictxt,anorm) - else - anorm = acsr3%csnmi() - endif - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') - goto 9999 - end if + anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) p%parms%aggr_omega_val = omega @@ -368,7 +311,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' - + else ! ! Build the smoothed prolongator using the original matrix @@ -409,76 +352,64 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call ptilde%free() call acsr1%set_dupl(psb_dupl_add_) - call am1%mv_from(acsr1) - if (ml_global_nmb) then - ! - ! Now we have to gather the halo of am1, and add it to itself - ! to multiply it by A, - ! - call psb_sphalo(am1,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) - if (info == psb_success_) call am4%free() - else - call psb_rwextd(ncol,am1,info) - endif + call op_prol%mv_from(acsr1) + ! + ! Now we have to gather the halo of op_prol, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(op_prol,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ - if (p%parms%aggr_kind == mld_smooth_prol_) then - call am1%transp(am2) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - i=0 - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then - i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) - end if - end do - call acoo%set_nzeros(i) - call acoo%trim() - call am2%mv_from(acoo) - call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') - goto 9999 + call op_prol%transp(op_restr) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) + ! + do k=1, nzl + if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then + i = i+1 + acoo%val(i) = acoo%val(k) + acoo%ia(i) = acoo%ia(k) + acoo%ja(i) = acoo%ja(k) end if - else - call am1%transp(am2) - endif + end do + call acoo%set_nzeros(i) + call acoo%trim() + call op_restr%mv_from(acoo) + call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') + goto 9999 + end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - if (p%parms%aggr_kind == mld_smooth_prol_) then - ! am2 = ((i-wDA)Ptilde)^T - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - else if (p%parms%aggr_kind == mld_biz_prol_) then - call psb_rwextd(ncol,am3,info) - endif + ! op_restr = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') goto 9999 @@ -488,160 +419,93 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) if (info == psb_success_) call am3%free() if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') goto 9999 end if - select case(p%parms%aggr_kind) - - case(mld_smooth_prol_) + select case(p%parms%coarse_mat) - select case(p%parms%coarse_mat) + case(mld_distr_mat_) - case(mld_distr_mat_) + nzl = b%get_nzeros() + call b%mv_to(bcoo) - nzac = b%get_nzeros() - nzl = nzac - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%ac%set_asb() - - if (info == psb_success_) deallocate(nzbr,idisp,stat=info) - 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 am1%mv_to(acsr1) - nzl = acsr1%get_nzeros() - call psb_glob_to_loc(acsr1%ja(1:nzl),p%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 am1%mv_from(acsr1) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%cscnv(info,type='coo',dupl=psb_dupl_add_) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo) - if (info == psb_success_) call am2%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - - if (info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 - end select - - - case(mld_biz_prol_) + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - select case(p%parms%coarse_mat) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - case(mld_distr_mat_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') + goto 9999 + end if - call psb_move_alloc(b,p%ac,info) - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%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 - - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + call op_prol%mv_from(acsr1) + endif + call op_prol%set_ncols(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + if (info == psb_success_) call op_restr%cscnv(info,type='csr') if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') goto 9999 end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 + end if + call op_restr%set_nrows(p%desc_ac%get_local_cols()) - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + if (info /= psb_success_) goto 9999 case default info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') goto 9999 - end select call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) @@ -652,14 +516,14 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator ! - + p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') goto 9999 diff --git a/mlprec/impl/mld_zaggrmat_asb.f90 b/mlprec/impl/mld_zaggrmat_asb.f90 index 91f14443..383e10a6 100644 --- a/mlprec/impl/mld_zaggrmat_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_asb.f90 @@ -113,6 +113,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables + type(psb_zspmat_type) :: b, op_prol,op_restr integer :: ictxt,np,me, err_act character(len=20) :: name @@ -128,15 +129,23 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') goto 9999 end if - case(mld_smooth_prol_,mld_biz_prol_) + case(mld_smooth_prol_) - call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + goto 9999 + end if + + case(mld_biz_prol_) + + call mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') goto 9999 @@ -144,7 +153,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_min_energy_) - call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') goto 9999 diff --git a/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 b/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 index fd72fe7e..104d71b9 100644 --- a/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 @@ -116,15 +116,15 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_zspmat_type) :: op_prol,op_restr, b ! Local variables - type(psb_zspmat_type) :: b integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt integer :: ictxt,np,me, err_act, icomm character(len=20) :: name - type(psb_zspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp + type(psb_zspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_zspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_zspmat_type) :: dat, datp, datdatp, atmp3 type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo @@ -280,7 +280,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call am3%mv_to(acsr3) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = cmplx(dzero,dzero) do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -354,17 +354,17 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*Af)Ptilde + ! op_prol = (I-w*D*Af)Ptilde ! Doing it this way means to consider diag(Af_i) ! ! - call psb_symbmm(af,ptilde,am1,info) + call psb_symbmm(af,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(af,ptilde,am1) + call psb_numbmm(af,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -390,16 +390,16 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*A)Ptilde + ! op_prol = (I-w*D*A)Ptilde ! ! - call psb_symbmm(am3,ptilde,am1,info) + call psb_symbmm(am3,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(am3,ptilde,am1) + call psb_numbmm(am3,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -458,7 +458,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) omp = omp/oden ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = cmplx(dzero,dzero) do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -509,20 +509,20 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call rtilde%mv_from(tmpcoo) call rtilde%cscnv(info,type='csr') - call psb_symbmm(rtilde,atmp,am2,info) - call psb_numbmm(rtilde,atmp,am2) + call psb_symbmm(rtilde,atmp,op_restr,info) + call psb_numbmm(rtilde,atmp,op_restr) ! - ! Now we have to gather the halo of am1, and add it to itself + ! Now we have to gather the halo of op_prol, and add it to itself ! to multiply it by A, ! - call psb_sphalo(am1,desc_a,am4,info,& + call psb_sphalo(op_prol,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if @@ -530,7 +530,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() i=0 @@ -543,21 +543,21 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) end if end do call tmpcoo%set_nzeros(i) - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2' @@ -576,14 +576,13 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) if (info == psb_success_) call am3%free() - call b%mv_to(bcoo) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = am2 x am3') + &a_err='Build b = op_restr x am3') goto 9999 end if @@ -597,6 +596,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_distr_mat_) + call b%mv_to(bcoo) nzl = bcoo%get_nzeros() if (debug_level >= psb_debug_outer_) & @@ -627,29 +627,29 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call p%ac%cscnv(info,type='csr') if (np>1) then - call am1%mv_to(acsr) + call op_prol%mv_to(acsr) nzl = acsr%get_nzeros() call psb_glob_to_loc(acsr%ja(1:nzl),p%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 am1%mv_from(acsr) + call op_prol%mv_from(acsr) endif - call am1%set_ncols(p%desc_ac%get_local_cols()) + call op_prol%set_ncols(p%desc_ac%get_local_cols()) if (np>1) then - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') goto 9999 end if - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') end if - call am2%set_nrows(p%desc_ac%get_local_cols()) + call op_restr%set_nrows(p%desc_ac%get_local_cols()) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -658,47 +658,55 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_repl_mat_) ! ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - nzbr(:) = 0 - nzbr(me+1) = bcoo%get_nzeros() - - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) - 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(bcoo%val,ndx,mpi_double_complex,tmpcoo%val,nzbr,idisp,& - & mpi_double_complex,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err=' from mpi_allgatherv') - goto 9999 - end if - - call bcoo%free() - call tmpcoo%fix(info) - call p%ac%mv_from(tmpcoo) - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') + goto 9999 + end if + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + if(info /= psb_success_) goto 9999 +!!$ call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) +!!$ nzbr(:) = 0 +!!$ nzbr(me+1) = bcoo%get_nzeros() +!!$ +!!$ call psb_sum(ictxt,nzbr(1:np)) +!!$ nzac = sum(nzbr) +!!$ if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) +!!$ if (info /= psb_success_) goto 9999 +!!$ +!!$ do ip=1,np +!!$ idispip) = sum(nzbr(1:ip-1)) +!!$ enddo +!!$ ndx = nzbr(me+1) +!!$ +!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_double_complex,tmpcoo%val,nzbr,idisp,& +!!$ & mpi_double_complex,icomm,info) +!!$ if (info == psb_success_)& +!!$ & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& +!!$ & psb_mpi_ipk_integer,icomm,info) +!!$ if (info == psb_success_)& +!!$ & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& +!!$ & psb_mpi_ipk_integer,icomm,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err=' from mpi_allgatherv') +!!$ goto 9999 +!!$ end if +!!$ +!!$ call bcoo%free() +!!$ call tmpcoo%fix(info) +!!$ call p%ac%mv_from(tmpcoo) +!!$ call p%ac%cscnv(info,type='csr') +!!$ if(info /= psb_success_) goto 9999 +!!$ +!!$ deallocate(nzbr,idisp,stat=info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') @@ -715,13 +723,13 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => R i.e. restriction operator - ! am1 => P i.e. prolongation operator + ! op_restr => R i.e. restriction operator + ! op_prol => P i.e. prolongation operator ! p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') goto 9999 diff --git a/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 b/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 index 40be6002..9e0f3e1f 100644 --- a/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 @@ -99,17 +99,17 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_zspmat_type) :: b, op_prol,op_restr ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name - type(psb_zspmat_type) :: b - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) - type(psb_zspmat_type) :: am1,am2 - type(psb_z_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & + type(psb_z_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo, acoo + type(psb_z_csr_sparse_mat) :: acsr1, acsr2 + integer :: debug_level, debug_unit + integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & & naggr, nzt, naggrm1, i name='mld_aggrmat_nosmth_asb' @@ -128,32 +128,19 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - 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 - naggrm1=sum(nlaggr(1:me)) - if (p%parms%coarse_mat == mld_repl_mat_) then - do i=1, nrow - ilaggr(i) = ilaggr(i) + naggrm1 - end do - call psb_halo(ilaggr,desc_a,info) - end if + do i=1, nrow + ilaggr(i) = ilaggr(i) + naggrm1 + end do + call psb_halo(ilaggr,desc_a,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') goto 9999 end if - if (p%parms%coarse_mat == mld_repl_mat_) then - call acoo1%allocate(ncol,ntaggr,ncol) - else - call acoo1%allocate(ncol,naggr,ncol) - end if + call acoo1%allocate(ncol,ntaggr,ncol) do i=1,nrow acoo1%val(i) = zone @@ -165,10 +152,13 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call acoo1%set_nzeros(nrow) call acoo1%set_asb() call acoo1%fix(info) - call acoo1%transp(acoo2) - call a%csclip(bcoo,info,jmax=nrow) + call op_prol%mv_from(acoo1) + call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call op_prol%transp(op_restr) + + call a%csclip(bcoo,info,jmax=nrow) nzt = bcoo%get_nzeros() do i=1, nzt @@ -181,6 +171,8 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call bcoo%fix(info) + call b%mv_from(bcoo) + if (p%parms%coarse_mat == mld_repl_mat_) then call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) @@ -189,55 +181,74 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') goto 9999 end if + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + if(info /= psb_success_) goto 9999 - nzbr(:) = 0 - nzbr(me+1) = nzt - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - - call ac_coo%allocate(ntaggr,ntaggr,nzac) + else if (p%parms%coarse_mat == mld_distr_mat_) then - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) + nzl = b%get_nzeros() + call b%mv_to(bcoo) - call mpi_allgatherv(bcoo%val,ndx,mpi_double_complex,ac_coo%val,nzbr,idisp,& - & mpi_double_complex,icomm,minfo) - call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if(info /= psb_success_) then - info=-1 - call psb_errpush(info,name) + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 end if - call ac_coo%set_nzeros(nzac) - call ac_coo%set_dupl(psb_dupl_add_) - call ac_coo%fix(info) - call p%ac%mv_from(ac_coo) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - else if (p%parms%coarse_mat == mld_distr_mat_) then + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - call p%ac%mv_from(bcoo) - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') + 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),p%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(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 - + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' else info = psb_err_internal_error_ call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') goto 9999 end if - call bcoo%free() - - deallocate(nzbr,idisp) call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) if(info /= psb_success_) then @@ -245,20 +256,16 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - call am1%mv_from(acoo1) - call am1%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo2) - if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator ! if (info == psb_success_) & & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') goto 9999 diff --git a/mlprec/impl/mld_zaggrmat_smth_asb.F90 b/mlprec/impl/mld_zaggrmat_smth_asb.F90 index 9eb44d94..883a47cc 100644 --- a/mlprec/impl/mld_zaggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_smth_asb.F90 @@ -61,11 +61,6 @@ ! according to the value of p%parms%aggr_omega_alg, specified by the user ! through mld_zprecinit and mld_zprecset. ! -! This routine can also build A_C according to a "bizarre" aggregation algorithm, -! using a "naive" prolongator proposed by the authors of MLD2P4. However, this -! prolongator still requires a deep analysis and testing and its use is not -! recommended. -! ! The coarse-level matrix A_C is distributed among the parallel processes or ! replicated on each of them, according to the value of p%parms%coarse_mat, ! specified by the user through mld_zprecinit and mld_zprecset. @@ -116,20 +111,19 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info + type(psb_zspmat_type) :: op_prol, op_restr, b ! Local variables - type(psb_zspmat_type) :: b - integer, allocatable :: nzbr(:), idisp(:) - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw integer ::ictxt, np, me, err_act character(len=20) :: name - type(psb_zspmat_type) :: am1,am2, am3, am4 + type(psb_zspmat_type) :: am3, am4 type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde complex(psb_dpk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) - logical :: ml_global_nmb, filter_mat + logical :: filter_mat integer :: debug_level, debug_unit integer, parameter :: ncmax=16 real(psb_dpk_) :: anorm, omega, tmp, dg, theta @@ -155,29 +149,16 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - 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 - naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& - & ( (p%parms%aggr_kind == mld_biz_prol_).and.& - & (p%parms%coarse_mat == mld_repl_mat_)) ) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) - if (ml_global_nmb) then - ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 - call psb_halo(ilaggr,desc_a,info) + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 end if ! naggr: number of local aggregates @@ -202,32 +183,22 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - if (ml_global_nmb) then - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - acoo%val(i) = zone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(ncol) - else - call acoo%allocate(ncol,naggr,ncol) - do i=1,nrow - acoo%val(i) = zone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(nrow) - endif + call acoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + acoo%val(i) = zone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) + end do + call acoo%set_nzeros(ncol) call acoo%set_dupl(psb_dupl_add_) - + call ptilde%mv_from_coo(acoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ' Initial copies sone.' - + if (filter_mat) then ! ! Build the filtered matrix Af from A @@ -285,35 +256,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (p%parms%aggr_eig == mld_max_norm_) then - if (p%parms%aggr_kind == mld_biz_prol_) then - - ! - ! This only works with CSR - ! - anorm = dzero - dg = done - nrw = acsr3%get_nrows() - do i=1, nrw - tmp = szero - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) <= nrw) then - tmp = tmp + abs(acsr3%val(j)) - endif - if (acsr3%ja(j) == i ) then - dg = abs(acsr3%val(j)) - end if - end do - anorm = max(anorm,tmp/dg) - enddo - - call psb_amx(ictxt,anorm) - else - anorm = acsr3%csnmi() - endif - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') - goto 9999 - end if + anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) p%parms%aggr_omega_val = omega @@ -368,7 +311,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' - + else ! ! Build the smoothed prolongator using the original matrix @@ -409,76 +352,64 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call ptilde%free() call acsr1%set_dupl(psb_dupl_add_) - call am1%mv_from(acsr1) - if (ml_global_nmb) then - ! - ! Now we have to gather the halo of am1, and add it to itself - ! to multiply it by A, - ! - call psb_sphalo(am1,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) - if (info == psb_success_) call am4%free() - else - call psb_rwextd(ncol,am1,info) - endif + call op_prol%mv_from(acsr1) + ! + ! Now we have to gather the halo of op_prol, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(op_prol,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ - if (p%parms%aggr_kind == mld_smooth_prol_) then - call am1%transp(am2) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - i=0 - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then - i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) - end if - end do - call acoo%set_nzeros(i) - call acoo%trim() - call am2%mv_from(acoo) - call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') - goto 9999 + call op_prol%transp(op_restr) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) + ! + do k=1, nzl + if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then + i = i+1 + acoo%val(i) = acoo%val(k) + acoo%ia(i) = acoo%ia(k) + acoo%ja(i) = acoo%ja(k) end if - else - call am1%transp(am2) - endif + end do + call acoo%set_nzeros(i) + call acoo%trim() + call op_restr%mv_from(acoo) + call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') + goto 9999 + end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - if (p%parms%aggr_kind == mld_smooth_prol_) then - ! am2 = ((i-wDA)Ptilde)^T - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - else if (p%parms%aggr_kind == mld_biz_prol_) then - call psb_rwextd(ncol,am3,info) - endif + ! op_restr = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') goto 9999 @@ -488,160 +419,93 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) if (info == psb_success_) call am3%free() if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') goto 9999 end if - select case(p%parms%aggr_kind) - - case(mld_smooth_prol_) + select case(p%parms%coarse_mat) - select case(p%parms%coarse_mat) + case(mld_distr_mat_) - case(mld_distr_mat_) + nzl = b%get_nzeros() + call b%mv_to(bcoo) - nzac = b%get_nzeros() - nzl = nzac - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%ac%set_asb() - - if (info == psb_success_) deallocate(nzbr,idisp,stat=info) - 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 am1%mv_to(acsr1) - nzl = acsr1%get_nzeros() - call psb_glob_to_loc(acsr1%ja(1:nzl),p%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 am1%mv_from(acsr1) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%cscnv(info,type='coo',dupl=psb_dupl_add_) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo) - if (info == psb_success_) call am2%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - - if (info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 - end select - - - case(mld_biz_prol_) + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - select case(p%parms%coarse_mat) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - case(mld_distr_mat_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') + goto 9999 + end if - call psb_move_alloc(b,p%ac,info) - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%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 - - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + call op_prol%mv_from(acsr1) + endif + call op_prol%set_ncols(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + if (info == psb_success_) call op_restr%cscnv(info,type='csr') if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') goto 9999 end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 + end if + call op_restr%set_nrows(p%desc_ac%get_local_cols()) - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + if (info /= psb_success_) goto 9999 case default info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') goto 9999 - end select call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) @@ -652,14 +516,14 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator ! - + p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') goto 9999 diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 27b456e1..83de58d5 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -157,6 +157,7 @@ module mld_base_prec_type integer, parameter :: mld_coarse_fillin_ = 32 integer, parameter :: mld_coarse_subsolve_ = 33 integer, parameter :: mld_smoother_sweeps_ = 34 + integer, parameter :: mld_coarse_aggr_size_ = 35 integer, parameter :: mld_ifpsz_ = 36 ! diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 5f47270c..27f89f04 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -130,6 +130,7 @@ module mld_c_inner_mod end subroutine mld_c_dec_map_bld end interface mld_dec_map_bld + interface mld_aggrmat_asb subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ @@ -142,20 +143,10 @@ module mld_c_inner_mod end subroutine mld_caggrmat_asb end interface mld_aggrmat_asb - interface mld_aggrmat_nosmth_asb - subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_c_onelev_type - type(psb_cspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_caggrmat_nosmth_asb - end interface mld_aggrmat_nosmth_asb + - interface mld_aggrmat_smth_asb - subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + abstract interface + subroutine mld_caggrmat_var_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ use mld_c_prec_type, only : mld_c_onelev_type type(psb_cspmat_type), intent(in) :: a @@ -163,19 +154,12 @@ module mld_c_inner_mod integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info - end subroutine mld_caggrmat_smth_asb - end interface mld_aggrmat_smth_asb + end subroutine mld_caggrmat_var_asb + end interface + + + procedure(mld_caggrmat_var_asb) :: mld_caggrmat_nosmth_asb, mld_caggrmat_smth_asb,& + & mld_caggrmat_minnrg_asb, mld_caggrmat_biz_asb - interface mld_aggrmat_minnrg_asb - subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_c_onelev_type - type(psb_cspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_caggrmat_minnrg_asb - end interface mld_aggrmat_minnrg_asb end module mld_c_inner_mod diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index dd544385..b32bf8c7 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -130,6 +130,7 @@ module mld_d_inner_mod end subroutine mld_d_dec_map_bld end interface mld_dec_map_bld + interface mld_aggrmat_asb subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ @@ -142,20 +143,10 @@ module mld_d_inner_mod end subroutine mld_daggrmat_asb end interface mld_aggrmat_asb - interface mld_aggrmat_nosmth_asb - subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_d_onelev_type - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_daggrmat_nosmth_asb - end interface mld_aggrmat_nosmth_asb + - interface mld_aggrmat_smth_asb - subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + abstract interface + subroutine mld_daggrmat_var_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ use mld_d_prec_type, only : mld_d_onelev_type type(psb_dspmat_type), intent(in) :: a @@ -163,19 +154,12 @@ module mld_d_inner_mod integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info - end subroutine mld_daggrmat_smth_asb - end interface mld_aggrmat_smth_asb + end subroutine mld_daggrmat_var_asb + end interface + + + procedure(mld_daggrmat_var_asb) :: mld_daggrmat_nosmth_asb, mld_daggrmat_smth_asb,& + & mld_daggrmat_minnrg_asb, mld_daggrmat_biz_asb - interface mld_aggrmat_minnrg_asb - subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_d_onelev_type - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_daggrmat_minnrg_asb - end interface mld_aggrmat_minnrg_asb end module mld_d_inner_mod diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index 74b4a1f7..86ba03f2 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -81,6 +81,7 @@ module mld_d_prec_type type, extends(psb_dprec_type) :: mld_dprec_type integer :: ictxt + integer :: coarse_aggr_size real(psb_dpk_) :: op_complexity=dzero type(mld_d_onelev_type), allocatable :: precv(:) contains diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index d5aeb204..9cc9461c 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -130,6 +130,7 @@ module mld_s_inner_mod end subroutine mld_s_dec_map_bld end interface mld_dec_map_bld + interface mld_aggrmat_asb subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ @@ -142,20 +143,10 @@ module mld_s_inner_mod end subroutine mld_saggrmat_asb end interface mld_aggrmat_asb - interface mld_aggrmat_nosmth_asb - subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_s_onelev_type - type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_saggrmat_nosmth_asb - end interface mld_aggrmat_nosmth_asb + - interface mld_aggrmat_smth_asb - subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + abstract interface + subroutine mld_saggrmat_var_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ use mld_s_prec_type, only : mld_s_onelev_type type(psb_sspmat_type), intent(in) :: a @@ -163,19 +154,12 @@ module mld_s_inner_mod integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info - end subroutine mld_saggrmat_smth_asb - end interface mld_aggrmat_smth_asb + end subroutine mld_saggrmat_var_asb + end interface + + + procedure(mld_saggrmat_var_asb) :: mld_saggrmat_nosmth_asb, mld_saggrmat_smth_asb,& + & mld_saggrmat_minnrg_asb, mld_saggrmat_biz_asb - interface mld_aggrmat_minnrg_asb - subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_s_onelev_type - type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_saggrmat_minnrg_asb - end interface mld_aggrmat_minnrg_asb end module mld_s_inner_mod diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index 647e1b88..c25f8683 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -130,6 +130,7 @@ module mld_z_inner_mod end subroutine mld_z_dec_map_bld end interface mld_dec_map_bld + interface mld_aggrmat_asb subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ @@ -142,20 +143,10 @@ module mld_z_inner_mod end subroutine mld_zaggrmat_asb end interface mld_aggrmat_asb - interface mld_aggrmat_nosmth_asb - subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_z_onelev_type - type(psb_zspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_zaggrmat_nosmth_asb - end interface mld_aggrmat_nosmth_asb + - interface mld_aggrmat_smth_asb - subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + abstract interface + subroutine mld_zaggrmat_var_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ use mld_z_prec_type, only : mld_z_onelev_type type(psb_zspmat_type), intent(in) :: a @@ -163,19 +154,12 @@ module mld_z_inner_mod integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info - end subroutine mld_zaggrmat_smth_asb - end interface mld_aggrmat_smth_asb + end subroutine mld_zaggrmat_var_asb + end interface + + + procedure(mld_zaggrmat_var_asb) :: mld_zaggrmat_nosmth_asb, mld_zaggrmat_smth_asb,& + & mld_zaggrmat_minnrg_asb, mld_zaggrmat_biz_asb - interface mld_aggrmat_minnrg_asb - subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_z_onelev_type - type(psb_zspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_zaggrmat_minnrg_asb - end interface mld_aggrmat_minnrg_asb end module mld_z_inner_mod diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 40165150..4e674318 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -17,7 +17,7 @@ ILU ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU 4 ! Smoother/Jacobi sweeps BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML 3 ! Number of levels in a multilevel preconditioner -SMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED +NONSMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED DEC ! Type of aggregation DEC SYMDEC GLB MULT ! Type of multilevel correction: ADD MULT TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) From 13d9fd75e88f12c6a4801eb66edd1a6e82fd0679 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 11 Apr 2012 13:11:44 +0000 Subject: [PATCH 04/11] mld2p4-tpre-NewNL: mlprec/impl/mld_caggrmat_minnrg_asb.F90 mlprec/impl/mld_caggrmat_nosmth_asb.F90 mlprec/impl/mld_caggrmat_smth_asb.F90 mlprec/impl/mld_daggrmat_minnrg_asb.F90 mlprec/impl/mld_daggrmat_nosmth_asb.F90 mlprec/impl/mld_daggrmat_smth_asb.F90 mlprec/impl/mld_saggrmat_minnrg_asb.F90 mlprec/impl/mld_saggrmat_nosmth_asb.F90 mlprec/impl/mld_saggrmat_smth_asb.F90 mlprec/impl/mld_zaggrmat_minnrg_asb.F90 mlprec/impl/mld_zaggrmat_nosmth_asb.F90 mlprec/impl/mld_zaggrmat_smth_asb.F90 MPI no longer used directly. Step 1. --- mlprec/impl/mld_caggrmat_minnrg_asb.F90 | 6 ------ mlprec/impl/mld_caggrmat_nosmth_asb.F90 | 6 ------ mlprec/impl/mld_caggrmat_smth_asb.F90 | 6 ------ mlprec/impl/mld_daggrmat_minnrg_asb.F90 | 6 ------ mlprec/impl/mld_daggrmat_nosmth_asb.F90 | 6 ------ mlprec/impl/mld_daggrmat_smth_asb.F90 | 6 ------ mlprec/impl/mld_saggrmat_minnrg_asb.F90 | 6 ------ mlprec/impl/mld_saggrmat_nosmth_asb.F90 | 6 ------ mlprec/impl/mld_saggrmat_smth_asb.F90 | 6 ------ mlprec/impl/mld_zaggrmat_minnrg_asb.F90 | 6 ------ mlprec/impl/mld_zaggrmat_nosmth_asb.F90 | 6 ------ mlprec/impl/mld_zaggrmat_smth_asb.F90 | 6 ------ 12 files changed, 72 deletions(-) diff --git a/mlprec/impl/mld_caggrmat_minnrg_asb.F90 b/mlprec/impl/mld_caggrmat_minnrg_asb.F90 index 00881369..0573e6f5 100644 --- a/mlprec/impl/mld_caggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_caggrmat_minnrg_asb.F90 @@ -102,13 +102,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_minnrg_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_cspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_caggrmat_nosmth_asb.F90 b/mlprec/impl/mld_caggrmat_nosmth_asb.F90 index fcaf10d6..4f4ad6af 100644 --- a/mlprec/impl/mld_caggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_caggrmat_nosmth_asb.F90 @@ -85,13 +85,7 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_nosmth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_cspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_caggrmat_smth_asb.F90 b/mlprec/impl/mld_caggrmat_smth_asb.F90 index 75ef464d..ede23f6d 100644 --- a/mlprec/impl/mld_caggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_caggrmat_smth_asb.F90 @@ -97,13 +97,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_smth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_cspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_daggrmat_minnrg_asb.F90 b/mlprec/impl/mld_daggrmat_minnrg_asb.F90 index bb5ae741..7e46a943 100644 --- a/mlprec/impl/mld_daggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.F90 @@ -102,13 +102,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_minnrg_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_dspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_daggrmat_nosmth_asb.F90 b/mlprec/impl/mld_daggrmat_nosmth_asb.F90 index d161bc04..b054fc78 100644 --- a/mlprec/impl/mld_daggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_daggrmat_nosmth_asb.F90 @@ -85,13 +85,7 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_nosmth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_dspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_daggrmat_smth_asb.F90 b/mlprec/impl/mld_daggrmat_smth_asb.F90 index af0c1fb4..f1c3126e 100644 --- a/mlprec/impl/mld_daggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_daggrmat_smth_asb.F90 @@ -97,13 +97,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_smth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_dspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_saggrmat_minnrg_asb.F90 b/mlprec/impl/mld_saggrmat_minnrg_asb.F90 index f35a9199..e9b46654 100644 --- a/mlprec/impl/mld_saggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_saggrmat_minnrg_asb.F90 @@ -102,13 +102,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_minnrg_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_sspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_saggrmat_nosmth_asb.F90 b/mlprec/impl/mld_saggrmat_nosmth_asb.F90 index 6f3eb3b6..e7c26afe 100644 --- a/mlprec/impl/mld_saggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_saggrmat_nosmth_asb.F90 @@ -85,13 +85,7 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_nosmth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_sspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_saggrmat_smth_asb.F90 b/mlprec/impl/mld_saggrmat_smth_asb.F90 index 76a44eb2..532d7a2a 100644 --- a/mlprec/impl/mld_saggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_saggrmat_smth_asb.F90 @@ -97,13 +97,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_smth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_sspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 b/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 index 104d71b9..834a7526 100644 --- a/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 @@ -102,13 +102,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_minnrg_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_zspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 b/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 index 9e0f3e1f..e83cc323 100644 --- a/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 @@ -85,13 +85,7 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_nosmth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_zspmat_type), intent(in) :: a diff --git a/mlprec/impl/mld_zaggrmat_smth_asb.F90 b/mlprec/impl/mld_zaggrmat_smth_asb.F90 index 883a47cc..e5f72174 100644 --- a/mlprec/impl/mld_zaggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_smth_asb.F90 @@ -97,13 +97,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_smth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_zspmat_type), intent(in) :: a From 029c78bbf48e7c401b5114ba226b8ef8a35760e0 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 11 Apr 2012 13:13:04 +0000 Subject: [PATCH 05/11] mld2p4-tpre-NewNL: mlprec/impl/mld_caggrmat_minnrg_asb.F90 mlprec/impl/mld_caggrmat_nosmth_asb.F90 mlprec/impl/mld_caggrmat_smth_asb.F90 mlprec/impl/mld_daggrmat_minnrg_asb.F90 mlprec/impl/mld_daggrmat_nosmth_asb.F90 mlprec/impl/mld_daggrmat_smth_asb.F90 mlprec/impl/mld_saggrmat_minnrg_asb.F90 mlprec/impl/mld_saggrmat_nosmth_asb.F90 mlprec/impl/mld_saggrmat_smth_asb.F90 mlprec/impl/mld_zaggrmat_minnrg_asb.F90 mlprec/impl/mld_zaggrmat_nosmth_asb.F90 mlprec/impl/mld_zaggrmat_smth_asb.F90 MPI no longer used directly. Step 1. --- mlprec/impl/mld_caggrmat_biz_asb.F90 | 523 +++++++++++++++++++++++++++ mlprec/impl/mld_daggrmat_biz_asb.F90 | 523 +++++++++++++++++++++++++++ mlprec/impl/mld_saggrmat_biz_asb.F90 | 523 +++++++++++++++++++++++++++ mlprec/impl/mld_zaggrmat_biz_asb.F90 | 523 +++++++++++++++++++++++++++ 4 files changed, 2092 insertions(+) create mode 100644 mlprec/impl/mld_caggrmat_biz_asb.F90 create mode 100644 mlprec/impl/mld_daggrmat_biz_asb.F90 create mode 100644 mlprec/impl/mld_saggrmat_biz_asb.F90 create mode 100644 mlprec/impl/mld_zaggrmat_biz_asb.F90 diff --git a/mlprec/impl/mld_caggrmat_biz_asb.F90 b/mlprec/impl/mld_caggrmat_biz_asb.F90 new file mode 100644 index 00000000..97d1ee4a --- /dev/null +++ b/mlprec/impl/mld_caggrmat_biz_asb.F90 @@ -0,0 +1,523 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_caggrmat_biz_asb.F90 +! +! Subroutine: mld_caggrmat_biz_asb +! Version: complex +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using the Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! This routine builds A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%parms%coarse_mat, +! specified by the user through mld_cprecinit and mld_zprecset. +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! p - type(mld_c_onelev_type), input/output. +! The 'one-level' data structure that will contain the local +! part of the matrix to be built as well as the information +! concerning the prolongator and its transpose. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! info - integer, output. +! Error code. +! +subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) + use psb_base_mod + use mld_c_inner_mod, mld_protect_name => mld_caggrmat_biz_asb + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_c_onelev_type), intent(inout), target :: p + integer, intent(out) :: info + type(psb_cspmat_type) :: op_prol, op_restr, b + + ! Local variables + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw + integer ::ictxt, np, me, err_act + character(len=20) :: name + type(psb_cspmat_type) :: am3, am4 + type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde + complex(psb_spk_), allocatable :: adiag(:) + integer(psb_ipk_) :: ierr(5) + logical :: filter_mat + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_spk_) :: anorm, omega, tmp, dg, theta + + name='mld_aggrmat_biz_asb' + if(psb_get_errstatus().ne.0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + nglob = desc_a%get_global_rows() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + theta = p%parms%aggr_thresh + + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + + filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(adiag(ncol),stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1)=nrow; + call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_spk_)') + goto 9999 + end if + + ! Get the diagonal D + call a%get_diag(adiag,info) + if (info == psb_success_) & + & call psb_halo(adiag,desc_a,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') + goto 9999 + end if + + ! 1. Allocate Ptilde in sparse matrix form + call acoo%allocate(ncol,naggr,ncol) + do i=1,nrow + acoo%val(i) = cone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) + end do + call acoo%set_nzeros(nrow) + call acoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(acoo,info) + if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies sone.' + + if (filter_mat) then + ! + ! Build the filtered matrix Af from A + ! + if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_) + + do i=1,nrow + tmp = czero + jd = -1 + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) jd = j + if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then + tmp=tmp+acsrf%val(j) + acsrf%val(j)=czero + endif + + enddo + if (jd == -1) then + write(0,*) 'Wrong input: we need the diagonal!!!!', i + else + acsrf%val(jd)=acsrf%val(jd)-tmp + end if + enddo + ! Take out zeroed terms + call acsrf%mv_to_coo(acoof,info) + k = 0 + do j=1,acoof%get_nzeros() + if ((acoof%val(j) /= czero) .or. (acoof%ia(j) == acoof%ja(j))) then + k = k + 1 + acoof%val(k) = acoof%val(j) + acoof%ia(k) = acoof%ia(j) + acoof%ja(k) = acoof%ja(j) + end if + end do + call acoof%set_nzeros(k) + call acoof%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(acoof,info) + end if + + + do i=1,size(adiag) + if (adiag(i) /= czero) then + adiag(i) = cone / adiag(i) + else + adiag(i) = cone + end if + end do + + if (filter_mat) call acsrf%scal(adiag,info) + if (info == psb_success_) call acsr3%scal(adiag,info) + if (info /= psb_success_) goto 9999 + + + if (p%parms%aggr_omega_alg == mld_eig_est_) then + + if (p%parms%aggr_eig == mld_max_norm_) then + + ! + ! This only works with CSR + ! + anorm = szero + dg = sone + nrw = acsr3%get_nrows() + do i=1, nrw + tmp = szero + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) <= nrw) then + tmp = tmp + abs(acsr3%val(j)) + endif + if (acsr3%ja(j) == i ) then + dg = abs(acsr3%val(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + p%parms%aggr_omega_val = omega + + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + else if (p%parms%aggr_omega_alg == mld_user_choice_) then + + omega = p%parms%aggr_omega_val + + else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') + goto 9999 + end if + + if (filter_mat) then + ! + ! Build the smoothed prolongator using the filtered matrix + ! + do i=1,acsrf%get_nrows() + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) then + acsrf%val(j) = cone - omega*acsrf%val(j) + else + acsrf%val(j) = - omega*acsrf%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*Af)Ptilde + ! Doing it this way means to consider diag(Af_i) + ! + ! + call psb_symbmm(acsrf,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsrf,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + else + ! + ! Build the smoothed prolongator using the original matrix + ! + do i=1,acsr3%get_nrows() + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) == i) then + acsr3%val(j) = cone - omega*acsr3%val(j) + else + acsr3%val(j) = - omega*acsr3%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*A)Ptilde + ! Doing it this way means to consider diag(A_i) + ! + ! + call psb_symbmm(acsr3,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsr3,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + end if + call ptilde%free() + call acsr1%set_dupl(psb_dupl_add_) + + call op_prol%mv_from(acsr1) + + call psb_rwextd(ncol,op_prol,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') + goto 9999 + end if + + call psb_symbmm(a,op_prol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,op_prol,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + + call op_prol%transp(op_restr) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + call psb_rwextd(ncol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') + goto 9999 + end if + + + + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = b%get_nzeros() + call b%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%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 p%ac%mv_from(bcoo) + + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%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),p%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(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,b,p%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 + + + + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_caggrmat_biz_asb diff --git a/mlprec/impl/mld_daggrmat_biz_asb.F90 b/mlprec/impl/mld_daggrmat_biz_asb.F90 new file mode 100644 index 00000000..91e0178d --- /dev/null +++ b/mlprec/impl/mld_daggrmat_biz_asb.F90 @@ -0,0 +1,523 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_daggrmat_biz_asb.F90 +! +! Subroutine: mld_daggrmat_biz_asb +! Version: real +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using the Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! This routine builds A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%parms%coarse_mat, +! specified by the user through mld_dprecinit and mld_zprecset. +! +! Arguments: +! a - type(psb_dspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! p - type(mld_d_onelev_type), input/output. +! The 'one-level' data structure that will contain the local +! part of the matrix to be built as well as the information +! concerning the prolongator and its transpose. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! info - integer, output. +! Error code. +! +subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) + use psb_base_mod + use mld_d_inner_mod, mld_protect_name => mld_daggrmat_biz_asb + + implicit none + + ! Arguments + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_d_onelev_type), intent(inout), target :: p + integer, intent(out) :: info + type(psb_dspmat_type) :: op_prol, op_restr, b + + ! Local variables + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw + integer ::ictxt, np, me, err_act + character(len=20) :: name + type(psb_dspmat_type) :: am3, am4 + type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde + real(psb_dpk_), allocatable :: adiag(:) + integer(psb_ipk_) :: ierr(5) + logical :: filter_mat + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_dpk_) :: anorm, omega, tmp, dg, theta + + name='mld_aggrmat_biz_asb' + if(psb_get_errstatus().ne.0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + nglob = desc_a%get_global_rows() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + theta = p%parms%aggr_thresh + + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + + filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(adiag(ncol),stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1)=nrow; + call psb_errpush(info,name,i_err=ierr,a_err='real(psb_dpk_)') + goto 9999 + end if + + ! Get the diagonal D + call a%get_diag(adiag,info) + if (info == psb_success_) & + & call psb_halo(adiag,desc_a,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') + goto 9999 + end if + + ! 1. Allocate Ptilde in sparse matrix form + call acoo%allocate(ncol,naggr,ncol) + do i=1,nrow + acoo%val(i) = done + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) + end do + call acoo%set_nzeros(nrow) + call acoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(acoo,info) + if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies sone.' + + if (filter_mat) then + ! + ! Build the filtered matrix Af from A + ! + if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_) + + do i=1,nrow + tmp = dzero + jd = -1 + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) jd = j + if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then + tmp=tmp+acsrf%val(j) + acsrf%val(j)=dzero + endif + + enddo + if (jd == -1) then + write(0,*) 'Wrong input: we need the diagonal!!!!', i + else + acsrf%val(jd)=acsrf%val(jd)-tmp + end if + enddo + ! Take out zeroed terms + call acsrf%mv_to_coo(acoof,info) + k = 0 + do j=1,acoof%get_nzeros() + if ((acoof%val(j) /= dzero) .or. (acoof%ia(j) == acoof%ja(j))) then + k = k + 1 + acoof%val(k) = acoof%val(j) + acoof%ia(k) = acoof%ia(j) + acoof%ja(k) = acoof%ja(j) + end if + end do + call acoof%set_nzeros(k) + call acoof%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(acoof,info) + end if + + + do i=1,size(adiag) + if (adiag(i) /= dzero) then + adiag(i) = done / adiag(i) + else + adiag(i) = done + end if + end do + + if (filter_mat) call acsrf%scal(adiag,info) + if (info == psb_success_) call acsr3%scal(adiag,info) + if (info /= psb_success_) goto 9999 + + + if (p%parms%aggr_omega_alg == mld_eig_est_) then + + if (p%parms%aggr_eig == mld_max_norm_) then + + ! + ! This only works with CSR + ! + anorm = dzero + dg = done + nrw = acsr3%get_nrows() + do i=1, nrw + tmp = dzero + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) <= nrw) then + tmp = tmp + abs(acsr3%val(j)) + endif + if (acsr3%ja(j) == i ) then + dg = abs(acsr3%val(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + p%parms%aggr_omega_val = omega + + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + else if (p%parms%aggr_omega_alg == mld_user_choice_) then + + omega = p%parms%aggr_omega_val + + else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') + goto 9999 + end if + + if (filter_mat) then + ! + ! Build the smoothed prolongator using the filtered matrix + ! + do i=1,acsrf%get_nrows() + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) then + acsrf%val(j) = done - omega*acsrf%val(j) + else + acsrf%val(j) = - omega*acsrf%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*Af)Ptilde + ! Doing it this way means to consider diag(Af_i) + ! + ! + call psb_symbmm(acsrf,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsrf,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + else + ! + ! Build the smoothed prolongator using the original matrix + ! + do i=1,acsr3%get_nrows() + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) == i) then + acsr3%val(j) = done - omega*acsr3%val(j) + else + acsr3%val(j) = - omega*acsr3%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*A)Ptilde + ! Doing it this way means to consider diag(A_i) + ! + ! + call psb_symbmm(acsr3,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsr3,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + end if + call ptilde%free() + call acsr1%set_dupl(psb_dupl_add_) + + call op_prol%mv_from(acsr1) + + call psb_rwextd(ncol,op_prol,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') + goto 9999 + end if + + call psb_symbmm(a,op_prol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,op_prol,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + + call op_prol%transp(op_restr) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + call psb_rwextd(ncol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') + goto 9999 + end if + + + + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = b%get_nzeros() + call b%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%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 p%ac%mv_from(bcoo) + + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%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),p%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(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,b,p%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 + + + + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_daggrmat_biz_asb diff --git a/mlprec/impl/mld_saggrmat_biz_asb.F90 b/mlprec/impl/mld_saggrmat_biz_asb.F90 new file mode 100644 index 00000000..e1bf0552 --- /dev/null +++ b/mlprec/impl/mld_saggrmat_biz_asb.F90 @@ -0,0 +1,523 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_saggrmat_biz_asb.F90 +! +! Subroutine: mld_saggrmat_biz_asb +! Version: real +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using the Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! This routine builds A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%parms%coarse_mat, +! specified by the user through mld_sprecinit and mld_zprecset. +! +! Arguments: +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! p - type(mld_s_onelev_type), input/output. +! The 'one-level' data structure that will contain the local +! part of the matrix to be built as well as the information +! concerning the prolongator and its transpose. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! info - integer, output. +! Error code. +! +subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) + use psb_base_mod + use mld_s_inner_mod, mld_protect_name => mld_saggrmat_biz_asb + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_s_onelev_type), intent(inout), target :: p + integer, intent(out) :: info + type(psb_sspmat_type) :: op_prol, op_restr, b + + ! Local variables + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw + integer ::ictxt, np, me, err_act + character(len=20) :: name + type(psb_sspmat_type) :: am3, am4 + type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde + real(psb_spk_), allocatable :: adiag(:) + integer(psb_ipk_) :: ierr(5) + logical :: filter_mat + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_spk_) :: anorm, omega, tmp, dg, theta + + name='mld_aggrmat_biz_asb' + if(psb_get_errstatus().ne.0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + nglob = desc_a%get_global_rows() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + theta = p%parms%aggr_thresh + + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + + filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(adiag(ncol),stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1)=nrow; + call psb_errpush(info,name,i_err=ierr,a_err='real(psb_spk_)') + goto 9999 + end if + + ! Get the diagonal D + call a%get_diag(adiag,info) + if (info == psb_success_) & + & call psb_halo(adiag,desc_a,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') + goto 9999 + end if + + ! 1. Allocate Ptilde in sparse matrix form + call acoo%allocate(ncol,naggr,ncol) + do i=1,nrow + acoo%val(i) = sone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) + end do + call acoo%set_nzeros(nrow) + call acoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(acoo,info) + if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies sone.' + + if (filter_mat) then + ! + ! Build the filtered matrix Af from A + ! + if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_) + + do i=1,nrow + tmp = szero + jd = -1 + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) jd = j + if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then + tmp=tmp+acsrf%val(j) + acsrf%val(j)=szero + endif + + enddo + if (jd == -1) then + write(0,*) 'Wrong input: we need the diagonal!!!!', i + else + acsrf%val(jd)=acsrf%val(jd)-tmp + end if + enddo + ! Take out zeroed terms + call acsrf%mv_to_coo(acoof,info) + k = 0 + do j=1,acoof%get_nzeros() + if ((acoof%val(j) /= szero) .or. (acoof%ia(j) == acoof%ja(j))) then + k = k + 1 + acoof%val(k) = acoof%val(j) + acoof%ia(k) = acoof%ia(j) + acoof%ja(k) = acoof%ja(j) + end if + end do + call acoof%set_nzeros(k) + call acoof%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(acoof,info) + end if + + + do i=1,size(adiag) + if (adiag(i) /= szero) then + adiag(i) = sone / adiag(i) + else + adiag(i) = sone + end if + end do + + if (filter_mat) call acsrf%scal(adiag,info) + if (info == psb_success_) call acsr3%scal(adiag,info) + if (info /= psb_success_) goto 9999 + + + if (p%parms%aggr_omega_alg == mld_eig_est_) then + + if (p%parms%aggr_eig == mld_max_norm_) then + + ! + ! This only works with CSR + ! + anorm = szero + dg = sone + nrw = acsr3%get_nrows() + do i=1, nrw + tmp = szero + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) <= nrw) then + tmp = tmp + abs(acsr3%val(j)) + endif + if (acsr3%ja(j) == i ) then + dg = abs(acsr3%val(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + p%parms%aggr_omega_val = omega + + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + else if (p%parms%aggr_omega_alg == mld_user_choice_) then + + omega = p%parms%aggr_omega_val + + else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') + goto 9999 + end if + + if (filter_mat) then + ! + ! Build the smoothed prolongator using the filtered matrix + ! + do i=1,acsrf%get_nrows() + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) then + acsrf%val(j) = sone - omega*acsrf%val(j) + else + acsrf%val(j) = - omega*acsrf%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*Af)Ptilde + ! Doing it this way means to consider diag(Af_i) + ! + ! + call psb_symbmm(acsrf,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsrf,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + else + ! + ! Build the smoothed prolongator using the original matrix + ! + do i=1,acsr3%get_nrows() + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) == i) then + acsr3%val(j) = sone - omega*acsr3%val(j) + else + acsr3%val(j) = - omega*acsr3%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*A)Ptilde + ! Doing it this way means to consider diag(A_i) + ! + ! + call psb_symbmm(acsr3,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsr3,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + end if + call ptilde%free() + call acsr1%set_dupl(psb_dupl_add_) + + call op_prol%mv_from(acsr1) + + call psb_rwextd(ncol,op_prol,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') + goto 9999 + end if + + call psb_symbmm(a,op_prol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,op_prol,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + + call op_prol%transp(op_restr) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + call psb_rwextd(ncol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') + goto 9999 + end if + + + + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = b%get_nzeros() + call b%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%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 p%ac%mv_from(bcoo) + + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%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),p%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(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,b,p%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 + + + + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_saggrmat_biz_asb diff --git a/mlprec/impl/mld_zaggrmat_biz_asb.F90 b/mlprec/impl/mld_zaggrmat_biz_asb.F90 new file mode 100644 index 00000000..3f43e05c --- /dev/null +++ b/mlprec/impl/mld_zaggrmat_biz_asb.F90 @@ -0,0 +1,523 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_zaggrmat_biz_asb.F90 +! +! Subroutine: mld_zaggrmat_biz_asb +! Version: complex +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using the Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! This routine builds A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%parms%coarse_mat, +! specified by the user through mld_zprecinit and mld_zprecset. +! +! Arguments: +! a - type(psb_zspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! p - type(mld_z_onelev_type), input/output. +! The 'one-level' data structure that will contain the local +! part of the matrix to be built as well as the information +! concerning the prolongator and its transpose. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! info - integer, output. +! Error code. +! +subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) + use psb_base_mod + use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_biz_asb + + implicit none + + ! Arguments + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_z_onelev_type), intent(inout), target :: p + integer, intent(out) :: info + type(psb_zspmat_type) :: op_prol, op_restr, b + + ! Local variables + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw + integer ::ictxt, np, me, err_act + character(len=20) :: name + type(psb_zspmat_type) :: am3, am4 + type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde + complex(psb_dpk_), allocatable :: adiag(:) + integer(psb_ipk_) :: ierr(5) + logical :: filter_mat + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_dpk_) :: anorm, omega, tmp, dg, theta + + name='mld_aggrmat_biz_asb' + if(psb_get_errstatus().ne.0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + nglob = desc_a%get_global_rows() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + theta = p%parms%aggr_thresh + + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + + filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(adiag(ncol),stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1)=nrow; + call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_dpk_)') + goto 9999 + end if + + ! Get the diagonal D + call a%get_diag(adiag,info) + if (info == psb_success_) & + & call psb_halo(adiag,desc_a,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') + goto 9999 + end if + + ! 1. Allocate Ptilde in sparse matrix form + call acoo%allocate(ncol,naggr,ncol) + do i=1,nrow + acoo%val(i) = zone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) + end do + call acoo%set_nzeros(nrow) + call acoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(acoo,info) + if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies sone.' + + if (filter_mat) then + ! + ! Build the filtered matrix Af from A + ! + if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_) + + do i=1,nrow + tmp = zzero + jd = -1 + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) jd = j + if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then + tmp=tmp+acsrf%val(j) + acsrf%val(j)=zzero + endif + + enddo + if (jd == -1) then + write(0,*) 'Wrong input: we need the diagonal!!!!', i + else + acsrf%val(jd)=acsrf%val(jd)-tmp + end if + enddo + ! Take out zeroed terms + call acsrf%mv_to_coo(acoof,info) + k = 0 + do j=1,acoof%get_nzeros() + if ((acoof%val(j) /= zzero) .or. (acoof%ia(j) == acoof%ja(j))) then + k = k + 1 + acoof%val(k) = acoof%val(j) + acoof%ia(k) = acoof%ia(j) + acoof%ja(k) = acoof%ja(j) + end if + end do + call acoof%set_nzeros(k) + call acoof%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(acoof,info) + end if + + + do i=1,size(adiag) + if (adiag(i) /= zzero) then + adiag(i) = zone / adiag(i) + else + adiag(i) = zone + end if + end do + + if (filter_mat) call acsrf%scal(adiag,info) + if (info == psb_success_) call acsr3%scal(adiag,info) + if (info /= psb_success_) goto 9999 + + + if (p%parms%aggr_omega_alg == mld_eig_est_) then + + if (p%parms%aggr_eig == mld_max_norm_) then + + ! + ! This only works with CSR + ! + anorm = dzero + dg = done + nrw = acsr3%get_nrows() + do i=1, nrw + tmp = dzero + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) <= nrw) then + tmp = tmp + abs(acsr3%val(j)) + endif + if (acsr3%ja(j) == i ) then + dg = abs(acsr3%val(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + p%parms%aggr_omega_val = omega + + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + else if (p%parms%aggr_omega_alg == mld_user_choice_) then + + omega = p%parms%aggr_omega_val + + else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') + goto 9999 + end if + + if (filter_mat) then + ! + ! Build the smoothed prolongator using the filtered matrix + ! + do i=1,acsrf%get_nrows() + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) then + acsrf%val(j) = zone - omega*acsrf%val(j) + else + acsrf%val(j) = - omega*acsrf%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*Af)Ptilde + ! Doing it this way means to consider diag(Af_i) + ! + ! + call psb_symbmm(acsrf,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsrf,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + else + ! + ! Build the smoothed prolongator using the original matrix + ! + do i=1,acsr3%get_nrows() + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) == i) then + acsr3%val(j) = zone - omega*acsr3%val(j) + else + acsr3%val(j) = - omega*acsr3%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*A)Ptilde + ! Doing it this way means to consider diag(A_i) + ! + ! + call psb_symbmm(acsr3,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsr3,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + end if + call ptilde%free() + call acsr1%set_dupl(psb_dupl_add_) + + call op_prol%mv_from(acsr1) + + call psb_rwextd(ncol,op_prol,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') + goto 9999 + end if + + call psb_symbmm(a,op_prol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,op_prol,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + + call op_prol%transp(op_restr) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + call psb_rwextd(ncol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(op_restr,am3,b,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') + goto 9999 + end if + + + + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = b%get_nzeros() + call b%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%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 p%ac%mv_from(bcoo) + + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%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),p%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(p%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(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,b,p%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 + + + + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_zaggrmat_biz_asb From acb96d42cfb9a7e3a8c82bf71b73aab26176b0d7 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 11 Apr 2012 13:33:20 +0000 Subject: [PATCH 06/11] mld2p4-tpre-NewNL: mlprec/impl/mld_caggrmat_biz_asb.F90 mlprec/impl/mld_caggrmat_biz_asb.f90 mlprec/impl/mld_caggrmat_minnrg_asb.F90 mlprec/impl/mld_caggrmat_minnrg_asb.f90 mlprec/impl/mld_caggrmat_nosmth_asb.F90 mlprec/impl/mld_caggrmat_nosmth_asb.f90 mlprec/impl/mld_caggrmat_smth_asb.F90 mlprec/impl/mld_caggrmat_smth_asb.f90 mlprec/impl/mld_daggrmat_biz_asb.F90 mlprec/impl/mld_daggrmat_biz_asb.f90 mlprec/impl/mld_daggrmat_minnrg_asb.F90 mlprec/impl/mld_daggrmat_minnrg_asb.f90 mlprec/impl/mld_daggrmat_nosmth_asb.F90 mlprec/impl/mld_daggrmat_nosmth_asb.f90 mlprec/impl/mld_daggrmat_smth_asb.F90 mlprec/impl/mld_daggrmat_smth_asb.f90 mlprec/impl/mld_saggrmat_biz_asb.F90 mlprec/impl/mld_saggrmat_biz_asb.f90 mlprec/impl/mld_saggrmat_minnrg_asb.F90 mlprec/impl/mld_saggrmat_minnrg_asb.f90 mlprec/impl/mld_saggrmat_nosmth_asb.F90 mlprec/impl/mld_saggrmat_nosmth_asb.f90 mlprec/impl/mld_saggrmat_smth_asb.F90 mlprec/impl/mld_saggrmat_smth_asb.f90 mlprec/impl/mld_zaggrmat_biz_asb.F90 mlprec/impl/mld_zaggrmat_biz_asb.f90 mlprec/impl/mld_zaggrmat_minnrg_asb.F90 mlprec/impl/mld_zaggrmat_minnrg_asb.f90 mlprec/impl/mld_zaggrmat_nosmth_asb.F90 mlprec/impl/mld_zaggrmat_nosmth_asb.f90 mlprec/impl/mld_zaggrmat_smth_asb.F90 mlprec/impl/mld_zaggrmat_smth_asb.f90 MPI no longer used directly. Step 2 --- .../impl/{mld_caggrmat_biz_asb.F90 => mld_caggrmat_biz_asb.f90} | 0 .../{mld_caggrmat_minnrg_asb.F90 => mld_caggrmat_minnrg_asb.f90} | 0 .../{mld_caggrmat_nosmth_asb.F90 => mld_caggrmat_nosmth_asb.f90} | 0 .../impl/{mld_caggrmat_smth_asb.F90 => mld_caggrmat_smth_asb.f90} | 0 .../impl/{mld_daggrmat_biz_asb.F90 => mld_daggrmat_biz_asb.f90} | 0 .../{mld_daggrmat_minnrg_asb.F90 => mld_daggrmat_minnrg_asb.f90} | 0 .../{mld_daggrmat_nosmth_asb.F90 => mld_daggrmat_nosmth_asb.f90} | 0 .../impl/{mld_daggrmat_smth_asb.F90 => mld_daggrmat_smth_asb.f90} | 0 .../impl/{mld_saggrmat_biz_asb.F90 => mld_saggrmat_biz_asb.f90} | 0 .../{mld_saggrmat_minnrg_asb.F90 => mld_saggrmat_minnrg_asb.f90} | 0 .../{mld_saggrmat_nosmth_asb.F90 => mld_saggrmat_nosmth_asb.f90} | 0 .../impl/{mld_saggrmat_smth_asb.F90 => mld_saggrmat_smth_asb.f90} | 0 .../impl/{mld_zaggrmat_biz_asb.F90 => mld_zaggrmat_biz_asb.f90} | 0 .../{mld_zaggrmat_minnrg_asb.F90 => mld_zaggrmat_minnrg_asb.f90} | 0 .../{mld_zaggrmat_nosmth_asb.F90 => mld_zaggrmat_nosmth_asb.f90} | 0 .../impl/{mld_zaggrmat_smth_asb.F90 => mld_zaggrmat_smth_asb.f90} | 0 16 files changed, 0 insertions(+), 0 deletions(-) rename mlprec/impl/{mld_caggrmat_biz_asb.F90 => mld_caggrmat_biz_asb.f90} (100%) rename mlprec/impl/{mld_caggrmat_minnrg_asb.F90 => mld_caggrmat_minnrg_asb.f90} (100%) rename mlprec/impl/{mld_caggrmat_nosmth_asb.F90 => mld_caggrmat_nosmth_asb.f90} (100%) rename mlprec/impl/{mld_caggrmat_smth_asb.F90 => mld_caggrmat_smth_asb.f90} (100%) rename mlprec/impl/{mld_daggrmat_biz_asb.F90 => mld_daggrmat_biz_asb.f90} (100%) rename mlprec/impl/{mld_daggrmat_minnrg_asb.F90 => mld_daggrmat_minnrg_asb.f90} (100%) rename mlprec/impl/{mld_daggrmat_nosmth_asb.F90 => mld_daggrmat_nosmth_asb.f90} (100%) rename mlprec/impl/{mld_daggrmat_smth_asb.F90 => mld_daggrmat_smth_asb.f90} (100%) rename mlprec/impl/{mld_saggrmat_biz_asb.F90 => mld_saggrmat_biz_asb.f90} (100%) rename mlprec/impl/{mld_saggrmat_minnrg_asb.F90 => mld_saggrmat_minnrg_asb.f90} (100%) rename mlprec/impl/{mld_saggrmat_nosmth_asb.F90 => mld_saggrmat_nosmth_asb.f90} (100%) rename mlprec/impl/{mld_saggrmat_smth_asb.F90 => mld_saggrmat_smth_asb.f90} (100%) rename mlprec/impl/{mld_zaggrmat_biz_asb.F90 => mld_zaggrmat_biz_asb.f90} (100%) rename mlprec/impl/{mld_zaggrmat_minnrg_asb.F90 => mld_zaggrmat_minnrg_asb.f90} (100%) rename mlprec/impl/{mld_zaggrmat_nosmth_asb.F90 => mld_zaggrmat_nosmth_asb.f90} (100%) rename mlprec/impl/{mld_zaggrmat_smth_asb.F90 => mld_zaggrmat_smth_asb.f90} (100%) diff --git a/mlprec/impl/mld_caggrmat_biz_asb.F90 b/mlprec/impl/mld_caggrmat_biz_asb.f90 similarity index 100% rename from mlprec/impl/mld_caggrmat_biz_asb.F90 rename to mlprec/impl/mld_caggrmat_biz_asb.f90 diff --git a/mlprec/impl/mld_caggrmat_minnrg_asb.F90 b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 similarity index 100% rename from mlprec/impl/mld_caggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_caggrmat_minnrg_asb.f90 diff --git a/mlprec/impl/mld_caggrmat_nosmth_asb.F90 b/mlprec/impl/mld_caggrmat_nosmth_asb.f90 similarity index 100% rename from mlprec/impl/mld_caggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_caggrmat_nosmth_asb.f90 diff --git a/mlprec/impl/mld_caggrmat_smth_asb.F90 b/mlprec/impl/mld_caggrmat_smth_asb.f90 similarity index 100% rename from mlprec/impl/mld_caggrmat_smth_asb.F90 rename to mlprec/impl/mld_caggrmat_smth_asb.f90 diff --git a/mlprec/impl/mld_daggrmat_biz_asb.F90 b/mlprec/impl/mld_daggrmat_biz_asb.f90 similarity index 100% rename from mlprec/impl/mld_daggrmat_biz_asb.F90 rename to mlprec/impl/mld_daggrmat_biz_asb.f90 diff --git a/mlprec/impl/mld_daggrmat_minnrg_asb.F90 b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 similarity index 100% rename from mlprec/impl/mld_daggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_daggrmat_minnrg_asb.f90 diff --git a/mlprec/impl/mld_daggrmat_nosmth_asb.F90 b/mlprec/impl/mld_daggrmat_nosmth_asb.f90 similarity index 100% rename from mlprec/impl/mld_daggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_daggrmat_nosmth_asb.f90 diff --git a/mlprec/impl/mld_daggrmat_smth_asb.F90 b/mlprec/impl/mld_daggrmat_smth_asb.f90 similarity index 100% rename from mlprec/impl/mld_daggrmat_smth_asb.F90 rename to mlprec/impl/mld_daggrmat_smth_asb.f90 diff --git a/mlprec/impl/mld_saggrmat_biz_asb.F90 b/mlprec/impl/mld_saggrmat_biz_asb.f90 similarity index 100% rename from mlprec/impl/mld_saggrmat_biz_asb.F90 rename to mlprec/impl/mld_saggrmat_biz_asb.f90 diff --git a/mlprec/impl/mld_saggrmat_minnrg_asb.F90 b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 similarity index 100% rename from mlprec/impl/mld_saggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_saggrmat_minnrg_asb.f90 diff --git a/mlprec/impl/mld_saggrmat_nosmth_asb.F90 b/mlprec/impl/mld_saggrmat_nosmth_asb.f90 similarity index 100% rename from mlprec/impl/mld_saggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_saggrmat_nosmth_asb.f90 diff --git a/mlprec/impl/mld_saggrmat_smth_asb.F90 b/mlprec/impl/mld_saggrmat_smth_asb.f90 similarity index 100% rename from mlprec/impl/mld_saggrmat_smth_asb.F90 rename to mlprec/impl/mld_saggrmat_smth_asb.f90 diff --git a/mlprec/impl/mld_zaggrmat_biz_asb.F90 b/mlprec/impl/mld_zaggrmat_biz_asb.f90 similarity index 100% rename from mlprec/impl/mld_zaggrmat_biz_asb.F90 rename to mlprec/impl/mld_zaggrmat_biz_asb.f90 diff --git a/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 similarity index 100% rename from mlprec/impl/mld_zaggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_zaggrmat_minnrg_asb.f90 diff --git a/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 b/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 similarity index 100% rename from mlprec/impl/mld_zaggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_zaggrmat_nosmth_asb.f90 diff --git a/mlprec/impl/mld_zaggrmat_smth_asb.F90 b/mlprec/impl/mld_zaggrmat_smth_asb.f90 similarity index 100% rename from mlprec/impl/mld_zaggrmat_smth_asb.F90 rename to mlprec/impl/mld_zaggrmat_smth_asb.f90 From 788d394f58a1d23c36065ded464769834abc1a93 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 11 Apr 2012 15:03:56 +0000 Subject: [PATCH 07/11] mld2p4-NewNL: mlprec/impl/mld_caggrmat_asb.f90 mlprec/impl/mld_caggrmat_biz_asb.f90 mlprec/impl/mld_caggrmat_minnrg_asb.f90 mlprec/impl/mld_caggrmat_nosmth_asb.f90 mlprec/impl/mld_caggrmat_smth_asb.f90 mlprec/impl/mld_daggrmat_asb.f90 mlprec/impl/mld_daggrmat_biz_asb.f90 mlprec/impl/mld_daggrmat_minnrg_asb.f90 mlprec/impl/mld_daggrmat_nosmth_asb.f90 mlprec/impl/mld_daggrmat_smth_asb.f90 mlprec/impl/mld_saggrmat_asb.f90 mlprec/impl/mld_saggrmat_biz_asb.f90 mlprec/impl/mld_saggrmat_minnrg_asb.f90 mlprec/impl/mld_saggrmat_nosmth_asb.f90 mlprec/impl/mld_saggrmat_smth_asb.f90 mlprec/impl/mld_zaggrmat_asb.f90 mlprec/impl/mld_zaggrmat_biz_asb.f90 mlprec/impl/mld_zaggrmat_minnrg_asb.f90 mlprec/impl/mld_zaggrmat_nosmth_asb.f90 mlprec/impl/mld_zaggrmat_smth_asb.f90 mlprec/mld_c_inner_mod.f90 mlprec/mld_d_inner_mod.f90 mlprec/mld_s_inner_mod.f90 mlprec/mld_z_inner_mod.f90 A bit of internal cleanup. --- mlprec/impl/mld_caggrmat_asb.f90 | 145 ++++++++++++++++--- mlprec/impl/mld_caggrmat_biz_asb.f90 | 165 ++++----------------- mlprec/impl/mld_caggrmat_minnrg_asb.f90 | 184 +++-------------------- mlprec/impl/mld_caggrmat_nosmth_asb.f90 | 144 +++--------------- mlprec/impl/mld_caggrmat_smth_asb.f90 | 185 ++++++------------------ mlprec/impl/mld_daggrmat_asb.f90 | 145 ++++++++++++++++--- mlprec/impl/mld_daggrmat_biz_asb.f90 | 165 ++++----------------- mlprec/impl/mld_daggrmat_minnrg_asb.f90 | 184 +++-------------------- mlprec/impl/mld_daggrmat_nosmth_asb.f90 | 144 +++--------------- mlprec/impl/mld_daggrmat_smth_asb.f90 | 185 ++++++------------------ mlprec/impl/mld_saggrmat_asb.f90 | 145 ++++++++++++++++--- mlprec/impl/mld_saggrmat_biz_asb.f90 | 165 ++++----------------- mlprec/impl/mld_saggrmat_minnrg_asb.f90 | 184 +++-------------------- mlprec/impl/mld_saggrmat_nosmth_asb.f90 | 144 +++--------------- mlprec/impl/mld_saggrmat_smth_asb.f90 | 185 ++++++------------------ mlprec/impl/mld_zaggrmat_asb.f90 | 145 ++++++++++++++++--- mlprec/impl/mld_zaggrmat_biz_asb.f90 | 165 ++++----------------- mlprec/impl/mld_zaggrmat_minnrg_asb.f90 | 184 +++-------------------- mlprec/impl/mld_zaggrmat_nosmth_asb.f90 | 144 +++--------------- mlprec/impl/mld_zaggrmat_smth_asb.f90 | 185 ++++++------------------ mlprec/mld_c_inner_mod.f90 | 7 +- mlprec/mld_d_inner_mod.f90 | 7 +- mlprec/mld_s_inner_mod.f90 | 7 +- mlprec/mld_z_inner_mod.f90 | 7 +- 24 files changed, 972 insertions(+), 2348 deletions(-) diff --git a/mlprec/impl/mld_caggrmat_asb.f90 b/mlprec/impl/mld_caggrmat_asb.f90 index 69cbc9c4..bfc5ef91 100644 --- a/mlprec/impl/mld_caggrmat_asb.f90 +++ b/mlprec/impl/mld_caggrmat_asb.f90 @@ -113,7 +113,11 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables - type(psb_cspmat_type) :: b, op_prol,op_restr + type(psb_cspmat_type) :: ac, op_prol,op_restr + type(psb_c_coo_sparse_mat) :: acoo, bcoo + type(psb_c_csr_sparse_mat) :: acsr1 + integer :: nzl,ntaggr + integer :: debug_level, debug_unit integer :: ictxt,np,me, err_act character(len=20) :: name @@ -121,6 +125,9 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) if(psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() @@ -129,43 +136,139 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') - goto 9999 - end if + call mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& + & p%parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) - call mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') - goto 9999 - end if + call mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) - call mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + call mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_min_energy_) + + call mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb') + goto 9999 + end if + + + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = ac%get_nzeros() + call ac%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%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 p%ac%mv_from(bcoo) - case(mld_min_energy_) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') goto 9999 end if - case default + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%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(p%desc_ac%get_local_cols()) - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') - goto 9999 + if (np>1) then + call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,ac,p%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 + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_caggrmat_biz_asb.f90 b/mlprec/impl/mld_caggrmat_biz_asb.f90 index 97d1ee4a..d278e4bf 100644 --- a/mlprec/impl/mld_caggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_caggrmat_biz_asb.f90 @@ -78,7 +78,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_biz_asb @@ -88,9 +88,9 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_cspmat_type) :: op_prol, op_restr, b ! Local variables integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& @@ -98,7 +98,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) integer ::ictxt, np, me, err_act character(len=20) :: name type(psb_cspmat_type) :: am3, am4 - type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_c_coo_sparse_mat) :: tmpcoo type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde complex(psb_spk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) @@ -123,7 +123,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -131,7 +131,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -163,16 +163,16 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,naggr,ncol) + call tmpcoo%allocate(ncol,naggr,ncol) do i=1,nrow - acoo%val(i) = cone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = cone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(nrow) - call acoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_nzeros(nrow) + call tmpcoo%set_dupl(psb_dupl_add_) - call ptilde%mv_from_coo(acoo,info) + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & @@ -203,19 +203,19 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= czero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -232,9 +232,9 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then + if (parms%aggr_omega_alg == mld_eig_est_) then - if (p%parms%aggr_eig == mld_max_norm_) then + if (parms%aggr_eig == mld_max_norm_) then ! ! This only works with CSR @@ -261,7 +261,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -269,11 +269,11 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -372,7 +372,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ call op_prol%transp(op_restr) if (debug_level >= psb_debug_outer_) & @@ -389,10 +389,10 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') goto 9999 @@ -401,107 +401,6 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%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 - - - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_caggrmat_minnrg_asb.f90 b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 index 0573e6f5..6344b4a7 100644 --- a/mlprec/impl/mld_caggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 @@ -98,7 +98,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_minnrg_asb @@ -108,9 +108,9 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_cspmat_type) :: op_prol,op_restr, b ! Local variables integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) @@ -121,8 +121,8 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_cspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_cspmat_type) :: dat, datp, datdatp, atmp3 - type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo - type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf + type(psb_c_coo_sparse_mat) :: tmpcoo + type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_c_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc complex(psb_spk_), allocatable :: adiag(:), adinv(:) complex(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:) @@ -150,7 +150,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -165,7 +165,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -207,16 +207,16 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = cone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = cone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) - call acoo%set_asb() - call ptilde%mv_from(acoo) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_asb() + call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') @@ -570,164 +570,18 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = op_restr x am3') + &a_err='Build ac = op_restr x am3') goto 9999 end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done mv_to_coo' - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call b%mv_to(bcoo) - nzl = bcoo%get_nzeros() - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' B matrix nzl: ',nzl - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 bcoo%set_nrows(p%desc_ac%get_local_rows()) - call bcoo%set_ncols(p%desc_ac%get_local_cols()) - call bcoo%fix(info) - call p%ac%mv_from(bcoo) - call p%ac%set_asb() - - call p%ac%cscnv(info,type='csr') - - if (np>1) then - call op_prol%mv_to(acsr) - nzl = acsr%get_nzeros() - call psb_glob_to_loc(acsr%ja(1:nzl),p%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(acsr) - endif - call op_prol%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') - goto 9999 - end if - call op_restr%mv_from(tmpcoo) - call op_restr%cscnv(info,type='csr') - end if - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 -!!$ call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) -!!$ nzbr(:) = 0 -!!$ nzbr(me+1) = bcoo%get_nzeros() -!!$ -!!$ call psb_sum(ictxt,nzbr(1:np)) -!!$ nzac = sum(nzbr) -!!$ if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) -!!$ if (info /= psb_success_) goto 9999 -!!$ -!!$ do ip=1,np -!!$ idispip) = sum(nzbr(1:ip-1)) -!!$ enddo -!!$ ndx = nzbr(me+1) -!!$ -!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_complex,tmpcoo%val,nzbr,idisp,& -!!$ & mpi_complex,icomm,info) -!!$ if (info == psb_success_)& -!!$ & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& -!!$ & psb_mpi_ipk_integer,icomm,info) -!!$ if (info == psb_success_)& -!!$ & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& -!!$ & psb_mpi_ipk_integer,icomm,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err=' from mpi_allgatherv') -!!$ goto 9999 -!!$ end if -!!$ -!!$ call bcoo%free() -!!$ call tmpcoo%fix(info) -!!$ call p%ac%mv_from(tmpcoo) -!!$ call p%ac%cscnv(info,type='csr') -!!$ if(info /= psb_success_) goto 9999 -!!$ -!!$ deallocate(nzbr,idisp,stat=info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => R i.e. restriction operator - ! op_prol => P i.e. prolongation operator - ! - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_caggrmat_nosmth_asb.f90 b/mlprec/impl/mld_caggrmat_nosmth_asb.f90 index 4f4ad6af..02294e6a 100644 --- a/mlprec/impl/mld_caggrmat_nosmth_asb.f90 +++ b/mlprec/impl/mld_caggrmat_nosmth_asb.f90 @@ -81,7 +81,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_nosmth_asb @@ -91,16 +91,16 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_cspmat_type) :: b, op_prol,op_restr ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name integer(psb_ipk_) :: ierr(5) - type(psb_c_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo, acoo + type(psb_c_coo_sparse_mat) :: ac_coo, acoo type(psb_c_csr_sparse_mat) :: acsr1, acsr2 integer :: debug_level, debug_unit integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & @@ -134,136 +134,36 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - call acoo1%allocate(ncol,ntaggr,ncol) + call acoo%allocate(ncol,ntaggr,ncol) do i=1,nrow - acoo1%val(i) = cone - acoo1%ia(i) = i - acoo1%ja(i) = ilaggr(i) + acoo%val(i) = cone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) end do - call acoo1%set_dupl(psb_dupl_add_) - call acoo1%set_nzeros(nrow) - call acoo1%set_asb() - call acoo1%fix(info) + call acoo%set_dupl(psb_dupl_add_) + call acoo%set_nzeros(nrow) + call acoo%set_asb() + call acoo%fix(info) - call op_prol%mv_from(acoo1) + call op_prol%mv_from(acoo) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) if (info == psb_success_) call op_prol%transp(op_restr) - call a%csclip(bcoo,info,jmax=nrow) + call a%csclip(ac_coo,info,jmax=nrow) - nzt = bcoo%get_nzeros() + nzt = ac_coo%get_nzeros() do i=1, nzt - bcoo%ia(i) = ilaggr(bcoo%ia(i)) - bcoo%ja(i) = ilaggr(bcoo%ja(i)) + ac_coo%ia(i) = ilaggr(ac_coo%ia(i)) + ac_coo%ja(i) = ilaggr(ac_coo%ja(i)) enddo - call bcoo%set_nrows(naggr) - call bcoo%set_ncols(naggr) - call bcoo%set_dupl(psb_dupl_add_) - call bcoo%fix(info) - - - call b%mv_from(bcoo) - - if (p%parms%coarse_mat == mld_repl_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 - - else if (p%parms%coarse_mat == mld_distr_mat_) then - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - else - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end if - - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - if (info == psb_success_) & - & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') - goto 9999 - end if + call ac_coo%set_nrows(naggr) + call ac_coo%set_ncols(naggr) + call ac_coo%set_dupl(psb_dupl_add_) + call ac_coo%fix(info) + call ac%mv_from(ac_coo) call psb_erractionrestore(err_act) diff --git a/mlprec/impl/mld_caggrmat_smth_asb.f90 b/mlprec/impl/mld_caggrmat_smth_asb.f90 index ede23f6d..d29321b7 100644 --- a/mlprec/impl/mld_caggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_caggrmat_smth_asb.f90 @@ -93,7 +93,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_smth_asb @@ -103,9 +103,9 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_cspmat_type) :: op_prol, op_restr, b ! Local variables integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& @@ -113,7 +113,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer ::ictxt, np, me, err_act character(len=20) :: name type(psb_cspmat_type) :: am3, am4 - type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_c_coo_sparse_mat) :: tmpcoo type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde complex(psb_spk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) @@ -138,14 +138,14 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -177,16 +177,16 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = cone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = cone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) - call ptilde%mv_from_coo(acoo,info) + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & @@ -217,19 +217,19 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= czero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -246,13 +246,13 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then + if (parms%aggr_omega_alg == mld_eig_est_) then - if (p%parms%aggr_eig == mld_max_norm_) then + if (parms%aggr_eig == mld_max_norm_) then anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -260,11 +260,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -369,27 +369,27 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ call op_prol%transp(op_restr) - call op_restr%mv_to(acoo) - nzl = acoo%get_nzeros() + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() i=0 ! ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then + if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) + tmpcoo%val(i) = tmpcoo%val(k) + tmpcoo%ia(i) = tmpcoo%ia(k) + tmpcoo%ja(i) = tmpcoo%ja(k) end if end do - call acoo%set_nzeros(i) - call acoo%trim() - call op_restr%mv_from(acoo) + call tmpcoo%set_nzeros(i) + call tmpcoo%trim() + call op_restr%mv_from(tmpcoo) call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') @@ -413,113 +413,12 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') - goto 9999 - end if - - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%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 - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3') goto 9999 end if diff --git a/mlprec/impl/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 index 7024b969..6dbb942b 100644 --- a/mlprec/impl/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -113,7 +113,11 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables - type(psb_dspmat_type) :: b, op_prol,op_restr + type(psb_dspmat_type) :: ac, op_prol,op_restr + type(psb_d_coo_sparse_mat) :: acoo, bcoo + type(psb_d_csr_sparse_mat) :: acsr1 + integer :: nzl,ntaggr + integer :: debug_level, debug_unit integer :: ictxt,np,me, err_act character(len=20) :: name @@ -121,6 +125,9 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) if(psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() @@ -129,43 +136,139 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') - goto 9999 - end if + call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& + & p%parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) - call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') - goto 9999 - end if + call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) - call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_min_energy_) + + call mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb') + goto 9999 + end if + + + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = ac%get_nzeros() + call ac%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%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 p%ac%mv_from(bcoo) - case(mld_min_energy_) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') goto 9999 end if - case default + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%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(p%desc_ac%get_local_cols()) - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') - goto 9999 + if (np>1) then + call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,ac,p%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 + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_daggrmat_biz_asb.f90 b/mlprec/impl/mld_daggrmat_biz_asb.f90 index 91e0178d..21ca67b6 100644 --- a/mlprec/impl/mld_daggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_daggrmat_biz_asb.f90 @@ -78,7 +78,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_biz_asb @@ -88,9 +88,9 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_dspmat_type) :: op_prol, op_restr, b ! Local variables integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& @@ -98,7 +98,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) integer ::ictxt, np, me, err_act character(len=20) :: name type(psb_dspmat_type) :: am3, am4 - type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_d_coo_sparse_mat) :: tmpcoo type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde real(psb_dpk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) @@ -123,7 +123,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -131,7 +131,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -163,16 +163,16 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,naggr,ncol) + call tmpcoo%allocate(ncol,naggr,ncol) do i=1,nrow - acoo%val(i) = done - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = done + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(nrow) - call acoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_nzeros(nrow) + call tmpcoo%set_dupl(psb_dupl_add_) - call ptilde%mv_from_coo(acoo,info) + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & @@ -203,19 +203,19 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= dzero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -232,9 +232,9 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then + if (parms%aggr_omega_alg == mld_eig_est_) then - if (p%parms%aggr_eig == mld_max_norm_) then + if (parms%aggr_eig == mld_max_norm_) then ! ! This only works with CSR @@ -261,7 +261,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -269,11 +269,11 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -372,7 +372,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ call op_prol%transp(op_restr) if (debug_level >= psb_debug_outer_) & @@ -389,10 +389,10 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') goto 9999 @@ -401,107 +401,6 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%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 - - - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 index 7e46a943..89e8e015 100644 --- a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 @@ -98,7 +98,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_minnrg_asb @@ -108,9 +108,9 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_dspmat_type) :: op_prol,op_restr, b ! Local variables integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) @@ -121,8 +121,8 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_dspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_dspmat_type) :: dat, datp, datdatp, atmp3 - type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo - type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf + type(psb_d_coo_sparse_mat) :: tmpcoo + type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_d_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc real(psb_dpk_), allocatable :: adiag(:), adinv(:) real(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:) @@ -150,7 +150,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -165,7 +165,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -207,16 +207,16 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = done - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = done + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) - call acoo%set_asb() - call ptilde%mv_from(acoo) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_asb() + call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') @@ -570,164 +570,18 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = op_restr x am3') + &a_err='Build ac = op_restr x am3') goto 9999 end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done mv_to_coo' - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call b%mv_to(bcoo) - nzl = bcoo%get_nzeros() - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' B matrix nzl: ',nzl - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 bcoo%set_nrows(p%desc_ac%get_local_rows()) - call bcoo%set_ncols(p%desc_ac%get_local_cols()) - call bcoo%fix(info) - call p%ac%mv_from(bcoo) - call p%ac%set_asb() - - call p%ac%cscnv(info,type='csr') - - if (np>1) then - call op_prol%mv_to(acsr) - nzl = acsr%get_nzeros() - call psb_glob_to_loc(acsr%ja(1:nzl),p%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(acsr) - endif - call op_prol%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') - goto 9999 - end if - call op_restr%mv_from(tmpcoo) - call op_restr%cscnv(info,type='csr') - end if - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 -!!$ call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) -!!$ nzbr(:) = 0 -!!$ nzbr(me+1) = bcoo%get_nzeros() -!!$ -!!$ call psb_sum(ictxt,nzbr(1:np)) -!!$ nzac = sum(nzbr) -!!$ if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) -!!$ if (info /= psb_success_) goto 9999 -!!$ -!!$ do ip=1,np -!!$ idispip) = sum(nzbr(1:ip-1)) -!!$ enddo -!!$ ndx = nzbr(me+1) -!!$ -!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,tmpcoo%val,nzbr,idisp,& -!!$ & mpi_double_precision,icomm,info) -!!$ if (info == psb_success_)& -!!$ & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& -!!$ & psb_mpi_ipk_integer,icomm,info) -!!$ if (info == psb_success_)& -!!$ & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& -!!$ & psb_mpi_ipk_integer,icomm,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err=' from mpi_allgatherv') -!!$ goto 9999 -!!$ end if -!!$ -!!$ call bcoo%free() -!!$ call tmpcoo%fix(info) -!!$ call p%ac%mv_from(tmpcoo) -!!$ call p%ac%cscnv(info,type='csr') -!!$ if(info /= psb_success_) goto 9999 -!!$ -!!$ deallocate(nzbr,idisp,stat=info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => R i.e. restriction operator - ! op_prol => P i.e. prolongation operator - ! - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_daggrmat_nosmth_asb.f90 b/mlprec/impl/mld_daggrmat_nosmth_asb.f90 index b054fc78..32f076f7 100644 --- a/mlprec/impl/mld_daggrmat_nosmth_asb.f90 +++ b/mlprec/impl/mld_daggrmat_nosmth_asb.f90 @@ -81,7 +81,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_nosmth_asb @@ -91,16 +91,16 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_dspmat_type) :: b, op_prol,op_restr ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name integer(psb_ipk_) :: ierr(5) - type(psb_d_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo, acoo + type(psb_d_coo_sparse_mat) :: ac_coo, acoo type(psb_d_csr_sparse_mat) :: acsr1, acsr2 integer :: debug_level, debug_unit integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & @@ -134,136 +134,36 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - call acoo1%allocate(ncol,ntaggr,ncol) + call acoo%allocate(ncol,ntaggr,ncol) do i=1,nrow - acoo1%val(i) = done - acoo1%ia(i) = i - acoo1%ja(i) = ilaggr(i) + acoo%val(i) = done + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) end do - call acoo1%set_dupl(psb_dupl_add_) - call acoo1%set_nzeros(nrow) - call acoo1%set_asb() - call acoo1%fix(info) + call acoo%set_dupl(psb_dupl_add_) + call acoo%set_nzeros(nrow) + call acoo%set_asb() + call acoo%fix(info) - call op_prol%mv_from(acoo1) + call op_prol%mv_from(acoo) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) if (info == psb_success_) call op_prol%transp(op_restr) - call a%csclip(bcoo,info,jmax=nrow) + call a%csclip(ac_coo,info,jmax=nrow) - nzt = bcoo%get_nzeros() + nzt = ac_coo%get_nzeros() do i=1, nzt - bcoo%ia(i) = ilaggr(bcoo%ia(i)) - bcoo%ja(i) = ilaggr(bcoo%ja(i)) + ac_coo%ia(i) = ilaggr(ac_coo%ia(i)) + ac_coo%ja(i) = ilaggr(ac_coo%ja(i)) enddo - call bcoo%set_nrows(naggr) - call bcoo%set_ncols(naggr) - call bcoo%set_dupl(psb_dupl_add_) - call bcoo%fix(info) - - - call b%mv_from(bcoo) - - if (p%parms%coarse_mat == mld_repl_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 - - else if (p%parms%coarse_mat == mld_distr_mat_) then - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - else - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end if - - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - if (info == psb_success_) & - & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') - goto 9999 - end if + call ac_coo%set_nrows(naggr) + call ac_coo%set_ncols(naggr) + call ac_coo%set_dupl(psb_dupl_add_) + call ac_coo%fix(info) + call ac%mv_from(ac_coo) call psb_erractionrestore(err_act) diff --git a/mlprec/impl/mld_daggrmat_smth_asb.f90 b/mlprec/impl/mld_daggrmat_smth_asb.f90 index f1c3126e..af616ece 100644 --- a/mlprec/impl/mld_daggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_daggrmat_smth_asb.f90 @@ -93,7 +93,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_smth_asb @@ -103,9 +103,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_dspmat_type) :: op_prol, op_restr, b ! Local variables integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& @@ -113,7 +113,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer ::ictxt, np, me, err_act character(len=20) :: name type(psb_dspmat_type) :: am3, am4 - type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_d_coo_sparse_mat) :: tmpcoo type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde real(psb_dpk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) @@ -138,14 +138,14 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -177,16 +177,16 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = done - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = done + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) - call ptilde%mv_from_coo(acoo,info) + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & @@ -217,19 +217,19 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= dzero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -246,13 +246,13 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then + if (parms%aggr_omega_alg == mld_eig_est_) then - if (p%parms%aggr_eig == mld_max_norm_) then + if (parms%aggr_eig == mld_max_norm_) then anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -260,11 +260,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -369,27 +369,27 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ call op_prol%transp(op_restr) - call op_restr%mv_to(acoo) - nzl = acoo%get_nzeros() + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() i=0 ! ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then + if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) + tmpcoo%val(i) = tmpcoo%val(k) + tmpcoo%ia(i) = tmpcoo%ia(k) + tmpcoo%ja(i) = tmpcoo%ja(k) end if end do - call acoo%set_nzeros(i) - call acoo%trim() - call op_restr%mv_from(acoo) + call tmpcoo%set_nzeros(i) + call tmpcoo%trim() + call op_restr%mv_from(tmpcoo) call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') @@ -413,113 +413,12 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') - goto 9999 - end if - - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%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 - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3') goto 9999 end if diff --git a/mlprec/impl/mld_saggrmat_asb.f90 b/mlprec/impl/mld_saggrmat_asb.f90 index 9ce3b701..5a84f116 100644 --- a/mlprec/impl/mld_saggrmat_asb.f90 +++ b/mlprec/impl/mld_saggrmat_asb.f90 @@ -113,7 +113,11 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables - type(psb_sspmat_type) :: b, op_prol,op_restr + type(psb_sspmat_type) :: ac, op_prol,op_restr + type(psb_s_coo_sparse_mat) :: acoo, bcoo + type(psb_s_csr_sparse_mat) :: acsr1 + integer :: nzl,ntaggr + integer :: debug_level, debug_unit integer :: ictxt,np,me, err_act character(len=20) :: name @@ -121,6 +125,9 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) if(psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() @@ -129,43 +136,139 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') - goto 9999 - end if + call mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& + & p%parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) - call mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') - goto 9999 - end if + call mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) - call mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + call mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_min_energy_) + + call mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb') + goto 9999 + end if + + + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = ac%get_nzeros() + call ac%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%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 p%ac%mv_from(bcoo) - case(mld_min_energy_) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') goto 9999 end if - case default + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%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(p%desc_ac%get_local_cols()) - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') - goto 9999 + if (np>1) then + call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,ac,p%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 + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_saggrmat_biz_asb.f90 b/mlprec/impl/mld_saggrmat_biz_asb.f90 index e1bf0552..df43f098 100644 --- a/mlprec/impl/mld_saggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_saggrmat_biz_asb.f90 @@ -78,7 +78,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_biz_asb @@ -88,9 +88,9 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_sspmat_type) :: op_prol, op_restr, b ! Local variables integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& @@ -98,7 +98,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) integer ::ictxt, np, me, err_act character(len=20) :: name type(psb_sspmat_type) :: am3, am4 - type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_s_coo_sparse_mat) :: tmpcoo type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde real(psb_spk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) @@ -123,7 +123,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -131,7 +131,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -163,16 +163,16 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,naggr,ncol) + call tmpcoo%allocate(ncol,naggr,ncol) do i=1,nrow - acoo%val(i) = sone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = sone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(nrow) - call acoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_nzeros(nrow) + call tmpcoo%set_dupl(psb_dupl_add_) - call ptilde%mv_from_coo(acoo,info) + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & @@ -203,19 +203,19 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= szero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -232,9 +232,9 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then + if (parms%aggr_omega_alg == mld_eig_est_) then - if (p%parms%aggr_eig == mld_max_norm_) then + if (parms%aggr_eig == mld_max_norm_) then ! ! This only works with CSR @@ -261,7 +261,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -269,11 +269,11 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -372,7 +372,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ call op_prol%transp(op_restr) if (debug_level >= psb_debug_outer_) & @@ -389,10 +389,10 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') goto 9999 @@ -401,107 +401,6 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%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 - - - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_saggrmat_minnrg_asb.f90 b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 index e9b46654..4e5ed449 100644 --- a/mlprec/impl/mld_saggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 @@ -98,7 +98,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_minnrg_asb @@ -108,9 +108,9 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_sspmat_type) :: op_prol,op_restr, b ! Local variables integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) @@ -121,8 +121,8 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_sspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_sspmat_type) :: dat, datp, datdatp, atmp3 - type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo - type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf + type(psb_s_coo_sparse_mat) :: tmpcoo + type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_s_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc real(psb_spk_), allocatable :: adiag(:), adinv(:) real(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:) @@ -150,7 +150,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -165,7 +165,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -207,16 +207,16 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = sone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = sone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) - call acoo%set_asb() - call ptilde%mv_from(acoo) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_asb() + call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') @@ -570,164 +570,18 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = op_restr x am3') + &a_err='Build ac = op_restr x am3') goto 9999 end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done mv_to_coo' - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call b%mv_to(bcoo) - nzl = bcoo%get_nzeros() - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' B matrix nzl: ',nzl - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 bcoo%set_nrows(p%desc_ac%get_local_rows()) - call bcoo%set_ncols(p%desc_ac%get_local_cols()) - call bcoo%fix(info) - call p%ac%mv_from(bcoo) - call p%ac%set_asb() - - call p%ac%cscnv(info,type='csr') - - if (np>1) then - call op_prol%mv_to(acsr) - nzl = acsr%get_nzeros() - call psb_glob_to_loc(acsr%ja(1:nzl),p%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(acsr) - endif - call op_prol%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') - goto 9999 - end if - call op_restr%mv_from(tmpcoo) - call op_restr%cscnv(info,type='csr') - end if - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 -!!$ call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) -!!$ nzbr(:) = 0 -!!$ nzbr(me+1) = bcoo%get_nzeros() -!!$ -!!$ call psb_sum(ictxt,nzbr(1:np)) -!!$ nzac = sum(nzbr) -!!$ if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) -!!$ if (info /= psb_success_) goto 9999 -!!$ -!!$ do ip=1,np -!!$ idispip) = sum(nzbr(1:ip-1)) -!!$ enddo -!!$ ndx = nzbr(me+1) -!!$ -!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_real,tmpcoo%val,nzbr,idisp,& -!!$ & mpi_real,icomm,info) -!!$ if (info == psb_success_)& -!!$ & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& -!!$ & psb_mpi_ipk_integer,icomm,info) -!!$ if (info == psb_success_)& -!!$ & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& -!!$ & psb_mpi_ipk_integer,icomm,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err=' from mpi_allgatherv') -!!$ goto 9999 -!!$ end if -!!$ -!!$ call bcoo%free() -!!$ call tmpcoo%fix(info) -!!$ call p%ac%mv_from(tmpcoo) -!!$ call p%ac%cscnv(info,type='csr') -!!$ if(info /= psb_success_) goto 9999 -!!$ -!!$ deallocate(nzbr,idisp,stat=info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => R i.e. restriction operator - ! op_prol => P i.e. prolongation operator - ! - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_saggrmat_nosmth_asb.f90 b/mlprec/impl/mld_saggrmat_nosmth_asb.f90 index e7c26afe..6a10da69 100644 --- a/mlprec/impl/mld_saggrmat_nosmth_asb.f90 +++ b/mlprec/impl/mld_saggrmat_nosmth_asb.f90 @@ -81,7 +81,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_nosmth_asb @@ -91,16 +91,16 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_sspmat_type) :: b, op_prol,op_restr ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name integer(psb_ipk_) :: ierr(5) - type(psb_s_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo, acoo + type(psb_s_coo_sparse_mat) :: ac_coo, acoo type(psb_s_csr_sparse_mat) :: acsr1, acsr2 integer :: debug_level, debug_unit integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & @@ -134,136 +134,36 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - call acoo1%allocate(ncol,ntaggr,ncol) + call acoo%allocate(ncol,ntaggr,ncol) do i=1,nrow - acoo1%val(i) = sone - acoo1%ia(i) = i - acoo1%ja(i) = ilaggr(i) + acoo%val(i) = sone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) end do - call acoo1%set_dupl(psb_dupl_add_) - call acoo1%set_nzeros(nrow) - call acoo1%set_asb() - call acoo1%fix(info) + call acoo%set_dupl(psb_dupl_add_) + call acoo%set_nzeros(nrow) + call acoo%set_asb() + call acoo%fix(info) - call op_prol%mv_from(acoo1) + call op_prol%mv_from(acoo) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) if (info == psb_success_) call op_prol%transp(op_restr) - call a%csclip(bcoo,info,jmax=nrow) + call a%csclip(ac_coo,info,jmax=nrow) - nzt = bcoo%get_nzeros() + nzt = ac_coo%get_nzeros() do i=1, nzt - bcoo%ia(i) = ilaggr(bcoo%ia(i)) - bcoo%ja(i) = ilaggr(bcoo%ja(i)) + ac_coo%ia(i) = ilaggr(ac_coo%ia(i)) + ac_coo%ja(i) = ilaggr(ac_coo%ja(i)) enddo - call bcoo%set_nrows(naggr) - call bcoo%set_ncols(naggr) - call bcoo%set_dupl(psb_dupl_add_) - call bcoo%fix(info) - - - call b%mv_from(bcoo) - - if (p%parms%coarse_mat == mld_repl_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 - - else if (p%parms%coarse_mat == mld_distr_mat_) then - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - else - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end if - - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - if (info == psb_success_) & - & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') - goto 9999 - end if + call ac_coo%set_nrows(naggr) + call ac_coo%set_ncols(naggr) + call ac_coo%set_dupl(psb_dupl_add_) + call ac_coo%fix(info) + call ac%mv_from(ac_coo) call psb_erractionrestore(err_act) diff --git a/mlprec/impl/mld_saggrmat_smth_asb.f90 b/mlprec/impl/mld_saggrmat_smth_asb.f90 index 532d7a2a..c38d9ec6 100644 --- a/mlprec/impl/mld_saggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_saggrmat_smth_asb.f90 @@ -93,7 +93,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_smth_asb @@ -103,9 +103,9 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_sspmat_type) :: op_prol, op_restr, b ! Local variables integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& @@ -113,7 +113,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer ::ictxt, np, me, err_act character(len=20) :: name type(psb_sspmat_type) :: am3, am4 - type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_s_coo_sparse_mat) :: tmpcoo type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde real(psb_spk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) @@ -138,14 +138,14 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -177,16 +177,16 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = sone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = sone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) - call ptilde%mv_from_coo(acoo,info) + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & @@ -217,19 +217,19 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= szero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -246,13 +246,13 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then + if (parms%aggr_omega_alg == mld_eig_est_) then - if (p%parms%aggr_eig == mld_max_norm_) then + if (parms%aggr_eig == mld_max_norm_) then anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -260,11 +260,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -369,27 +369,27 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ call op_prol%transp(op_restr) - call op_restr%mv_to(acoo) - nzl = acoo%get_nzeros() + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() i=0 ! ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then + if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) + tmpcoo%val(i) = tmpcoo%val(k) + tmpcoo%ia(i) = tmpcoo%ia(k) + tmpcoo%ja(i) = tmpcoo%ja(k) end if end do - call acoo%set_nzeros(i) - call acoo%trim() - call op_restr%mv_from(acoo) + call tmpcoo%set_nzeros(i) + call tmpcoo%trim() + call op_restr%mv_from(tmpcoo) call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') @@ -413,113 +413,12 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') - goto 9999 - end if - - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%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 - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3') goto 9999 end if diff --git a/mlprec/impl/mld_zaggrmat_asb.f90 b/mlprec/impl/mld_zaggrmat_asb.f90 index 383e10a6..f0d0e55a 100644 --- a/mlprec/impl/mld_zaggrmat_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_asb.f90 @@ -113,7 +113,11 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables - type(psb_zspmat_type) :: b, op_prol,op_restr + type(psb_zspmat_type) :: ac, op_prol,op_restr + type(psb_z_coo_sparse_mat) :: acoo, bcoo + type(psb_z_csr_sparse_mat) :: acsr1 + integer :: nzl,ntaggr + integer :: debug_level, debug_unit integer :: ictxt,np,me, err_act character(len=20) :: name @@ -121,6 +125,9 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) if(psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() @@ -129,43 +136,139 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') - goto 9999 - end if + call mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& + & p%parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) - call mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') - goto 9999 - end if + call mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) - call mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + call mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_min_energy_) + + call mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb') + goto 9999 + end if + + + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = ac%get_nzeros() + call ac%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%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 p%ac%mv_from(bcoo) - case(mld_min_energy_) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') goto 9999 end if - case default + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%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(p%desc_ac%get_local_cols()) - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') - goto 9999 + if (np>1) then + call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + 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 + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,ac,p%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 + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_zaggrmat_biz_asb.f90 b/mlprec/impl/mld_zaggrmat_biz_asb.f90 index 3f43e05c..f8d945f7 100644 --- a/mlprec/impl/mld_zaggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_biz_asb.f90 @@ -78,7 +78,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_biz_asb @@ -88,9 +88,9 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_zspmat_type) :: op_prol, op_restr, b ! Local variables integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& @@ -98,7 +98,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) integer ::ictxt, np, me, err_act character(len=20) :: name type(psb_zspmat_type) :: am3, am4 - type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_z_coo_sparse_mat) :: tmpcoo type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde complex(psb_dpk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) @@ -123,7 +123,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -131,7 +131,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -163,16 +163,16 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,naggr,ncol) + call tmpcoo%allocate(ncol,naggr,ncol) do i=1,nrow - acoo%val(i) = zone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = zone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(nrow) - call acoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_nzeros(nrow) + call tmpcoo%set_dupl(psb_dupl_add_) - call ptilde%mv_from_coo(acoo,info) + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & @@ -203,19 +203,19 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= zzero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -232,9 +232,9 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then + if (parms%aggr_omega_alg == mld_eig_est_) then - if (p%parms%aggr_eig == mld_max_norm_) then + if (parms%aggr_eig == mld_max_norm_) then ! ! This only works with CSR @@ -261,7 +261,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -269,11 +269,11 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -372,7 +372,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ call op_prol%transp(op_restr) if (debug_level >= psb_debug_outer_) & @@ -389,10 +389,10 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') goto 9999 @@ -401,107 +401,6 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,p,info) - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%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 - - - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 index 834a7526..fc76615a 100644 --- a/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 @@ -98,7 +98,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_minnrg_asb @@ -108,9 +108,9 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_zspmat_type) :: op_prol,op_restr, b ! Local variables integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) @@ -121,8 +121,8 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_zspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_zspmat_type) :: dat, datp, datdatp, atmp3 - type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo - type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf + type(psb_z_coo_sparse_mat) :: tmpcoo + type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_z_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc complex(psb_dpk_), allocatable :: adiag(:), adinv(:) complex(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:) @@ -150,7 +150,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -165,7 +165,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -207,16 +207,16 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = zone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = zone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) - call acoo%set_asb() - call ptilde%mv_from(acoo) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_asb() + call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') @@ -570,164 +570,18 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = op_restr x am3') + &a_err='Build ac = op_restr x am3') goto 9999 end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done mv_to_coo' - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call b%mv_to(bcoo) - nzl = bcoo%get_nzeros() - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' B matrix nzl: ',nzl - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 bcoo%set_nrows(p%desc_ac%get_local_rows()) - call bcoo%set_ncols(p%desc_ac%get_local_cols()) - call bcoo%fix(info) - call p%ac%mv_from(bcoo) - call p%ac%set_asb() - - call p%ac%cscnv(info,type='csr') - - if (np>1) then - call op_prol%mv_to(acsr) - nzl = acsr%get_nzeros() - call psb_glob_to_loc(acsr%ja(1:nzl),p%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(acsr) - endif - call op_prol%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') - goto 9999 - end if - call op_restr%mv_from(tmpcoo) - call op_restr%cscnv(info,type='csr') - end if - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 -!!$ call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) -!!$ nzbr(:) = 0 -!!$ nzbr(me+1) = bcoo%get_nzeros() -!!$ -!!$ call psb_sum(ictxt,nzbr(1:np)) -!!$ nzac = sum(nzbr) -!!$ if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) -!!$ if (info /= psb_success_) goto 9999 -!!$ -!!$ do ip=1,np -!!$ idispip) = sum(nzbr(1:ip-1)) -!!$ enddo -!!$ ndx = nzbr(me+1) -!!$ -!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_double_complex,tmpcoo%val,nzbr,idisp,& -!!$ & mpi_double_complex,icomm,info) -!!$ if (info == psb_success_)& -!!$ & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& -!!$ & psb_mpi_ipk_integer,icomm,info) -!!$ if (info == psb_success_)& -!!$ & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& -!!$ & psb_mpi_ipk_integer,icomm,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err=' from mpi_allgatherv') -!!$ goto 9999 -!!$ end if -!!$ -!!$ call bcoo%free() -!!$ call tmpcoo%fix(info) -!!$ call p%ac%mv_from(tmpcoo) -!!$ call p%ac%cscnv(info,type='csr') -!!$ if(info /= psb_success_) goto 9999 -!!$ -!!$ deallocate(nzbr,idisp,stat=info) -!!$ if (info /= psb_success_) then -!!$ info = psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => R i.e. restriction operator - ! op_prol => P i.e. prolongation operator - ! - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 b/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 index e83cc323..85239315 100644 --- a/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 @@ -81,7 +81,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_nosmth_asb @@ -91,16 +91,16 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_zspmat_type) :: b, op_prol,op_restr ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name integer(psb_ipk_) :: ierr(5) - type(psb_z_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo, acoo + type(psb_z_coo_sparse_mat) :: ac_coo, acoo type(psb_z_csr_sparse_mat) :: acsr1, acsr2 integer :: debug_level, debug_unit integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & @@ -134,136 +134,36 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - call acoo1%allocate(ncol,ntaggr,ncol) + call acoo%allocate(ncol,ntaggr,ncol) do i=1,nrow - acoo1%val(i) = zone - acoo1%ia(i) = i - acoo1%ja(i) = ilaggr(i) + acoo%val(i) = zone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) end do - call acoo1%set_dupl(psb_dupl_add_) - call acoo1%set_nzeros(nrow) - call acoo1%set_asb() - call acoo1%fix(info) + call acoo%set_dupl(psb_dupl_add_) + call acoo%set_nzeros(nrow) + call acoo%set_asb() + call acoo%fix(info) - call op_prol%mv_from(acoo1) + call op_prol%mv_from(acoo) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) if (info == psb_success_) call op_prol%transp(op_restr) - call a%csclip(bcoo,info,jmax=nrow) + call a%csclip(ac_coo,info,jmax=nrow) - nzt = bcoo%get_nzeros() + nzt = ac_coo%get_nzeros() do i=1, nzt - bcoo%ia(i) = ilaggr(bcoo%ia(i)) - bcoo%ja(i) = ilaggr(bcoo%ja(i)) + ac_coo%ia(i) = ilaggr(ac_coo%ia(i)) + ac_coo%ja(i) = ilaggr(ac_coo%ja(i)) enddo - call bcoo%set_nrows(naggr) - call bcoo%set_ncols(naggr) - call bcoo%set_dupl(psb_dupl_add_) - call bcoo%fix(info) - - - call b%mv_from(bcoo) - - if (p%parms%coarse_mat == mld_repl_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 - - else if (p%parms%coarse_mat == mld_distr_mat_) then - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - else - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end if - - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - if (info == psb_success_) & - & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') - goto 9999 - end if + call ac_coo%set_nrows(naggr) + call ac_coo%set_ncols(naggr) + call ac_coo%set_dupl(psb_dupl_add_) + call ac_coo%fix(info) + call ac%mv_from(ac_coo) call psb_erractionrestore(err_act) diff --git a/mlprec/impl/mld_zaggrmat_smth_asb.f90 b/mlprec/impl/mld_zaggrmat_smth_asb.f90 index e5f72174..b33be1ce 100644 --- a/mlprec/impl/mld_zaggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_smth_asb.f90 @@ -93,7 +93,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_smth_asb @@ -103,9 +103,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info - type(psb_zspmat_type) :: op_prol, op_restr, b ! Local variables integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& @@ -113,7 +113,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) integer ::ictxt, np, me, err_act character(len=20) :: name type(psb_zspmat_type) :: am3, am4 - type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_z_coo_sparse_mat) :: tmpcoo type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde complex(psb_dpk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) @@ -138,14 +138,14 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -177,16 +177,16 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = zone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = zone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) - call ptilde%mv_from_coo(acoo,info) + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & @@ -217,19 +217,19 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= zzero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -246,13 +246,13 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then + if (parms%aggr_omega_alg == mld_eig_est_) then - if (p%parms%aggr_eig == mld_max_norm_) then + if (parms%aggr_eig == mld_max_norm_) then anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -260,11 +260,11 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -369,27 +369,27 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ call op_prol%transp(op_restr) - call op_restr%mv_to(acoo) - nzl = acoo%get_nzeros() + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() i=0 ! ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then + if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) + tmpcoo%val(i) = tmpcoo%val(k) + tmpcoo%ia(i) = tmpcoo%ia(k) + tmpcoo%ja(i) = tmpcoo%ja(k) end if end do - call acoo%set_nzeros(i) - call acoo%trim() - call op_restr%mv_from(acoo) + call tmpcoo%set_nzeros(i) + call tmpcoo%trim() + call op_restr%mv_from(tmpcoo) call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') @@ -413,113 +413,12 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(op_restr,am3,b,info) - if (info == psb_success_) call psb_numbmm(op_restr,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') - goto 9999 - end if - - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = b%get_nzeros() - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%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 p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%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),p%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(p%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(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call op_restr%mv_from(acoo) - 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 - call op_restr%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%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 - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! op_restr => PR^T i.e. restriction operator - ! op_prol => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) - if (info == psb_success_) call op_prol%free() - if (info == psb_success_) call op_restr%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3') goto 9999 end if diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 27f89f04..566ab38f 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -146,13 +146,14 @@ module mld_c_inner_mod abstract interface - subroutine mld_caggrmat_var_asb(a,desc_a,ilaggr,nlaggr,p,info) + subroutine mld_caggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_c_onelev_type + use mld_c_prec_type, only : mld_c_onelev_type, mld_sml_parms type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info end subroutine mld_caggrmat_var_asb end interface diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index b32bf8c7..5278ec15 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -146,13 +146,14 @@ module mld_d_inner_mod abstract interface - subroutine mld_daggrmat_var_asb(a,desc_a,ilaggr,nlaggr,p,info) + subroutine mld_daggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_d_onelev_type + use mld_d_prec_type, only : mld_d_onelev_type, mld_dml_parms type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info end subroutine mld_daggrmat_var_asb end interface diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index 9cc9461c..d6b3badf 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -146,13 +146,14 @@ module mld_s_inner_mod abstract interface - subroutine mld_saggrmat_var_asb(a,desc_a,ilaggr,nlaggr,p,info) + subroutine mld_saggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_s_onelev_type + use mld_s_prec_type, only : mld_s_onelev_type, mld_sml_parms type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info end subroutine mld_saggrmat_var_asb end interface diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index c25f8683..4b630ae0 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -146,13 +146,14 @@ module mld_z_inner_mod abstract interface - subroutine mld_zaggrmat_var_asb(a,desc_a,ilaggr,nlaggr,p,info) + subroutine mld_zaggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_z_onelev_type + use mld_z_prec_type, only : mld_z_onelev_type, mld_dml_parms type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info end subroutine mld_zaggrmat_var_asb end interface From 9c4259c3d4273e927bba2bd689d490ada5b2d8ba Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 11 Apr 2012 15:41:35 +0000 Subject: [PATCH 08/11] mld2p4-tpre-newNL mlprec/mld_c_inner_mod.f90 mlprec/mld_d_inner_mod.f90 mlprec/mld_s_inner_mod.f90 mlprec/mld_z_inner_mod.f90 Pretty-printing. --- mlprec/mld_c_inner_mod.f90 | 15 ++++++++------- mlprec/mld_d_inner_mod.f90 | 15 ++++++++------- mlprec/mld_s_inner_mod.f90 | 15 ++++++++------- mlprec/mld_z_inner_mod.f90 | 15 ++++++++------- 4 files changed, 32 insertions(+), 28 deletions(-) diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 566ab38f..8cf313d0 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -149,18 +149,19 @@ module mld_c_inner_mod subroutine mld_caggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ use mld_c_prec_type, only : mld_c_onelev_type, mld_sml_parms - type(psb_cspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr - integer, intent(out) :: info + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info end subroutine mld_caggrmat_var_asb end interface - procedure(mld_caggrmat_var_asb) :: mld_caggrmat_nosmth_asb, mld_caggrmat_smth_asb,& - & mld_caggrmat_minnrg_asb, mld_caggrmat_biz_asb + procedure(mld_caggrmat_var_asb) :: mld_caggrmat_nosmth_asb, & + & mld_caggrmat_smth_asb, mld_caggrmat_minnrg_asb, & + & mld_caggrmat_biz_asb end module mld_c_inner_mod diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index 5278ec15..b07aec6c 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -149,18 +149,19 @@ module mld_d_inner_mod subroutine mld_daggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ use mld_d_prec_type, only : mld_d_onelev_type, mld_dml_parms - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr - integer, intent(out) :: info + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info end subroutine mld_daggrmat_var_asb end interface - procedure(mld_daggrmat_var_asb) :: mld_daggrmat_nosmth_asb, mld_daggrmat_smth_asb,& - & mld_daggrmat_minnrg_asb, mld_daggrmat_biz_asb + procedure(mld_daggrmat_var_asb) :: mld_daggrmat_nosmth_asb, & + & mld_daggrmat_smth_asb, mld_daggrmat_minnrg_asb, & + & mld_daggrmat_biz_asb end module mld_d_inner_mod diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index d6b3badf..db48e913 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -149,18 +149,19 @@ module mld_s_inner_mod subroutine mld_saggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ use mld_s_prec_type, only : mld_s_onelev_type, mld_sml_parms - type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr - integer, intent(out) :: info + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info end subroutine mld_saggrmat_var_asb end interface - procedure(mld_saggrmat_var_asb) :: mld_saggrmat_nosmth_asb, mld_saggrmat_smth_asb,& - & mld_saggrmat_minnrg_asb, mld_saggrmat_biz_asb + procedure(mld_saggrmat_var_asb) :: mld_saggrmat_nosmth_asb, & + & mld_saggrmat_smth_asb, mld_saggrmat_minnrg_asb, & + & mld_saggrmat_biz_asb end module mld_s_inner_mod diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index 4b630ae0..4b05ceb8 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -149,18 +149,19 @@ module mld_z_inner_mod subroutine mld_zaggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ use mld_z_prec_type, only : mld_z_onelev_type, mld_dml_parms - type(psb_zspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr - integer, intent(out) :: info + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info end subroutine mld_zaggrmat_var_asb end interface - procedure(mld_zaggrmat_var_asb) :: mld_zaggrmat_nosmth_asb, mld_zaggrmat_smth_asb,& - & mld_zaggrmat_minnrg_asb, mld_zaggrmat_biz_asb + procedure(mld_zaggrmat_var_asb) :: mld_zaggrmat_nosmth_asb, & + & mld_zaggrmat_smth_asb, mld_zaggrmat_minnrg_asb, & + & mld_zaggrmat_biz_asb end module mld_z_inner_mod From aab68f2bf3d70ca35e85b18e1c0a2bf9eade9fef Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 30 Apr 2012 10:18:31 +0000 Subject: [PATCH 09/11] mld2p4-NewNL: mlprec/impl/mld_c_base_smoother_impl.f90 mlprec/impl/mld_c_onelev_impl.f90 mlprec/impl/mld_d_base_smoother_impl.f90 mlprec/impl/mld_d_onelev_impl.f90 mlprec/impl/mld_s_base_smoother_impl.f90 mlprec/impl/mld_s_onelev_impl.f90 mlprec/impl/mld_z_base_smoother_impl.f90 mlprec/impl/mld_z_onelev_impl.f90 Fix recursive deallocate calls. --- mlprec/impl/mld_c_base_smoother_impl.f90 | 2 +- mlprec/impl/mld_c_onelev_impl.f90 | 3 ++- mlprec/impl/mld_d_base_smoother_impl.f90 | 2 +- mlprec/impl/mld_d_onelev_impl.f90 | 3 ++- mlprec/impl/mld_s_base_smoother_impl.f90 | 2 +- mlprec/impl/mld_s_onelev_impl.f90 | 3 ++- mlprec/impl/mld_z_base_smoother_impl.f90 | 2 +- mlprec/impl/mld_z_onelev_impl.f90 | 3 ++- 8 files changed, 12 insertions(+), 8 deletions(-) diff --git a/mlprec/impl/mld_c_base_smoother_impl.f90 b/mlprec/impl/mld_c_base_smoother_impl.f90 index af9ecdb6..2e6c886e 100644 --- a/mlprec/impl/mld_c_base_smoother_impl.f90 +++ b/mlprec/impl/mld_c_base_smoother_impl.f90 @@ -355,8 +355,8 @@ subroutine mld_c_base_smoother_free(sm,info) if (allocated(sm%sv)) then call sm%sv%free(info) + if (info == psb_success_) deallocate(sm%sv,stat=info) end if - if (info == psb_success_) deallocate(sm%sv,stat=info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/mld_c_onelev_impl.f90 b/mlprec/impl/mld_c_onelev_impl.f90 index d3be182f..e5faa843 100644 --- a/mlprec/impl/mld_c_onelev_impl.f90 +++ b/mlprec/impl/mld_c_onelev_impl.f90 @@ -150,7 +150,8 @@ subroutine mld_c_base_onelev_free(lv,info) ! that there may be inner objects containing C pointers, ! e.g. UMFPACK, SLU or CUDA stuff. ! We really need FINALs. - call lv%sm%free(info) + if (allocated(lv%sm)) & + & call lv%sm%free(info) call lv%ac%free() if (psb_is_ok_desc(lv%desc_ac)) & diff --git a/mlprec/impl/mld_d_base_smoother_impl.f90 b/mlprec/impl/mld_d_base_smoother_impl.f90 index ea293a6a..2e8dc53f 100644 --- a/mlprec/impl/mld_d_base_smoother_impl.f90 +++ b/mlprec/impl/mld_d_base_smoother_impl.f90 @@ -355,8 +355,8 @@ subroutine mld_d_base_smoother_free(sm,info) if (allocated(sm%sv)) then call sm%sv%free(info) + if (info == psb_success_) deallocate(sm%sv,stat=info) end if - if (info == psb_success_) deallocate(sm%sv,stat=info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/mld_d_onelev_impl.f90 b/mlprec/impl/mld_d_onelev_impl.f90 index 976545f1..46d0ccab 100644 --- a/mlprec/impl/mld_d_onelev_impl.f90 +++ b/mlprec/impl/mld_d_onelev_impl.f90 @@ -150,7 +150,8 @@ subroutine mld_d_base_onelev_free(lv,info) ! that there may be inner objects containing C pointers, ! e.g. UMFPACK, SLU or CUDA stuff. ! We really need FINALs. - call lv%sm%free(info) + if (allocated(lv%sm)) & + & call lv%sm%free(info) call lv%ac%free() if (psb_is_ok_desc(lv%desc_ac)) & diff --git a/mlprec/impl/mld_s_base_smoother_impl.f90 b/mlprec/impl/mld_s_base_smoother_impl.f90 index fad7365c..0807a8e0 100644 --- a/mlprec/impl/mld_s_base_smoother_impl.f90 +++ b/mlprec/impl/mld_s_base_smoother_impl.f90 @@ -355,8 +355,8 @@ subroutine mld_s_base_smoother_free(sm,info) if (allocated(sm%sv)) then call sm%sv%free(info) + if (info == psb_success_) deallocate(sm%sv,stat=info) end if - if (info == psb_success_) deallocate(sm%sv,stat=info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/mld_s_onelev_impl.f90 b/mlprec/impl/mld_s_onelev_impl.f90 index fb7538af..18cc7154 100644 --- a/mlprec/impl/mld_s_onelev_impl.f90 +++ b/mlprec/impl/mld_s_onelev_impl.f90 @@ -150,7 +150,8 @@ subroutine mld_s_base_onelev_free(lv,info) ! that there may be inner objects containing C pointers, ! e.g. UMFPACK, SLU or CUDA stuff. ! We really need FINALs. - call lv%sm%free(info) + if (allocated(lv%sm)) & + & call lv%sm%free(info) call lv%ac%free() if (psb_is_ok_desc(lv%desc_ac)) & diff --git a/mlprec/impl/mld_z_base_smoother_impl.f90 b/mlprec/impl/mld_z_base_smoother_impl.f90 index fc196730..5bba7df8 100644 --- a/mlprec/impl/mld_z_base_smoother_impl.f90 +++ b/mlprec/impl/mld_z_base_smoother_impl.f90 @@ -355,8 +355,8 @@ subroutine mld_z_base_smoother_free(sm,info) if (allocated(sm%sv)) then call sm%sv%free(info) + if (info == psb_success_) deallocate(sm%sv,stat=info) end if - if (info == psb_success_) deallocate(sm%sv,stat=info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/mld_z_onelev_impl.f90 b/mlprec/impl/mld_z_onelev_impl.f90 index 5825871b..1bdc04de 100644 --- a/mlprec/impl/mld_z_onelev_impl.f90 +++ b/mlprec/impl/mld_z_onelev_impl.f90 @@ -150,7 +150,8 @@ subroutine mld_z_base_onelev_free(lv,info) ! that there may be inner objects containing C pointers, ! e.g. UMFPACK, SLU or CUDA stuff. ! We really need FINALs. - call lv%sm%free(info) + if (allocated(lv%sm)) & + & call lv%sm%free(info) call lv%ac%free() if (psb_is_ok_desc(lv%desc_ac)) & From 96ddd0a2bb1ef41ffc6cb634d8422ec94f2155ec Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 30 Apr 2012 15:11:33 +0000 Subject: [PATCH 10/11] mld2p4-NewNL: mlprec/Makefile mlprec/impl/mld_c_onelev_impl.f90 mlprec/impl/mld_cmlprec_bld.f90 mlprec/impl/mld_cprecinit.F90 mlprec/impl/mld_cprecset.F90 mlprec/impl/mld_d_onelev_impl.f90 mlprec/impl/mld_dmlprec_bld.f90 mlprec/impl/mld_s_onelev_impl.f90 mlprec/impl/mld_smlprec_bld.f90 mlprec/impl/mld_sprecinit.F90 mlprec/impl/mld_sprecset.F90 mlprec/impl/mld_z_onelev_impl.f90 mlprec/impl/mld_zmlprec_bld.f90 mlprec/impl/mld_zprecinit.F90 mlprec/impl/mld_zprecset.F90 mlprec/mld_base_prec_type.F90 mlprec/mld_c_inner_mod.f90 mlprec/mld_c_move_alloc_mod.f90 mlprec/mld_c_onelev_mod.f90 mlprec/mld_c_prec_mod.f90 mlprec/mld_c_prec_type.f90 mlprec/mld_d_inner_mod.f90 mlprec/mld_d_move_alloc_mod.f90 mlprec/mld_d_onelev_mod.f90 mlprec/mld_d_prec_mod.f90 mlprec/mld_d_prec_type.f90 mlprec/mld_s_inner_mod.f90 mlprec/mld_s_move_alloc_mod.f90 mlprec/mld_s_onelev_mod.f90 mlprec/mld_s_prec_mod.f90 mlprec/mld_s_prec_type.f90 mlprec/mld_z_inner_mod.f90 mlprec/mld_z_move_alloc_mod.f90 mlprec/mld_z_onelev_mod.f90 mlprec/mld_z_prec_mod.f90 mlprec/mld_z_prec_type.f90 tests/pdegen/ppde2d.f90 tests/pdegen/ppde3d.f90 tests/pdegen/runs/ppde.inp tests/pdegen/spde2d.f90 tests/pdegen/spde3d.f90 Working version of choice of levels with coarse space size. --- mlprec/Makefile | 32 ++-- mlprec/impl/mld_c_onelev_impl.f90 | 2 +- mlprec/impl/mld_cmlprec_bld.f90 | 267 ++++++++++++++++++++---------- mlprec/impl/mld_cprecinit.F90 | 1 + mlprec/impl/mld_cprecset.F90 | 5 + mlprec/impl/mld_d_onelev_impl.f90 | 2 +- mlprec/impl/mld_dmlprec_bld.f90 | 267 ++++++++++++++++++++---------- mlprec/impl/mld_s_onelev_impl.f90 | 2 +- mlprec/impl/mld_smlprec_bld.f90 | 267 ++++++++++++++++++++---------- mlprec/impl/mld_sprecinit.F90 | 1 + mlprec/impl/mld_sprecset.F90 | 5 + mlprec/impl/mld_z_onelev_impl.f90 | 2 +- mlprec/impl/mld_zmlprec_bld.f90 | 267 ++++++++++++++++++++---------- mlprec/impl/mld_zprecinit.F90 | 1 + mlprec/impl/mld_zprecset.F90 | 5 + mlprec/mld_base_prec_type.F90 | 37 +++++ mlprec/mld_c_inner_mod.f90 | 2 - mlprec/mld_c_move_alloc_mod.f90 | 1 + mlprec/mld_c_onelev_mod.f90 | 26 +++ mlprec/mld_c_prec_mod.f90 | 1 - mlprec/mld_c_prec_type.f90 | 34 +++- mlprec/mld_d_inner_mod.f90 | 2 - mlprec/mld_d_move_alloc_mod.f90 | 1 + mlprec/mld_d_onelev_mod.f90 | 26 +++ mlprec/mld_d_prec_mod.f90 | 1 - mlprec/mld_d_prec_type.f90 | 35 +++- mlprec/mld_s_inner_mod.f90 | 2 - mlprec/mld_s_move_alloc_mod.f90 | 1 + mlprec/mld_s_onelev_mod.f90 | 26 +++ mlprec/mld_s_prec_mod.f90 | 1 - mlprec/mld_s_prec_type.f90 | 34 +++- mlprec/mld_z_inner_mod.f90 | 2 - mlprec/mld_z_move_alloc_mod.f90 | 1 + mlprec/mld_z_onelev_mod.f90 | 26 +++ mlprec/mld_z_prec_mod.f90 | 1 - mlprec/mld_z_prec_type.f90 | 34 +++- tests/pdegen/ppde2d.f90 | 4 + tests/pdegen/ppde3d.f90 | 4 + tests/pdegen/runs/ppde.inp | 5 +- tests/pdegen/spde2d.f90 | 4 + tests/pdegen/spde3d.f90 | 4 + 41 files changed, 1046 insertions(+), 395 deletions(-) diff --git a/mlprec/Makefile b/mlprec/Makefile index 0650ba5d..e2cce546 100644 --- a/mlprec/Makefile +++ b/mlprec/Makefile @@ -7,22 +7,22 @@ HERE=. FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR) -DMODOBJS=mld_d_prec_type.o mld_d_prec_mod.o mld_d_move_alloc_mod.o mld_d_ilu_fact_mod.o \ +DMODOBJS=mld_d_prec_type.o mld_d_prec_mod.o mld_d_ilu_fact_mod.o \ mld_d_inner_mod.o mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \ mld_d_umf_solver.o mld_d_slu_solver.o mld_d_sludist_solver.o mld_d_id_solver.o\ mld_d_base_solver_mod.o mld_d_base_smoother_mod.o mld_d_onelev_mod.o -SMODOBJS=mld_s_prec_type.o mld_s_prec_mod.o mld_s_move_alloc_mod.o mld_s_ilu_fact_mod.o \ +SMODOBJS=mld_s_prec_type.o mld_s_prec_mod.o mld_s_ilu_fact_mod.o \ mld_s_inner_mod.o mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_jac_smoother.o mld_s_as_smoother.o \ mld_s_slu_solver.o mld_s_sludist_solver.o mld_s_id_solver.o\ mld_s_base_solver_mod.o mld_s_base_smoother_mod.o mld_s_onelev_mod.o -ZMODOBJS=mld_z_prec_type.o mld_z_prec_mod.o mld_z_move_alloc_mod.o mld_z_ilu_fact_mod.o \ +ZMODOBJS=mld_z_prec_type.o mld_z_prec_mod.o mld_z_ilu_fact_mod.o \ mld_z_inner_mod.o mld_z_ilu_solver.o mld_z_diag_solver.o mld_z_jac_smoother.o mld_z_as_smoother.o \ mld_z_umf_solver.o mld_z_slu_solver.o mld_z_sludist_solver.o mld_z_id_solver.o\ mld_z_base_solver_mod.o mld_z_base_smoother_mod.o mld_z_onelev_mod.o -CMODOBJS=mld_c_prec_type.o mld_c_prec_mod.o mld_c_move_alloc_mod.o mld_c_ilu_fact_mod.o \ +CMODOBJS=mld_c_prec_type.o mld_c_prec_mod.o mld_c_ilu_fact_mod.o \ mld_c_inner_mod.o mld_c_ilu_solver.o mld_c_diag_solver.o mld_c_jac_smoother.o mld_c_as_smoother.o \ mld_c_slu_solver.o mld_c_sludist_solver.o mld_c_id_solver.o\ mld_c_base_solver_mod.o mld_c_base_smoother_mod.o mld_c_onelev_mod.o @@ -63,20 +63,15 @@ $(DINNEROBJS) $(DOUTEROBJS): $(DMODOBJS) $(CINNEROBJS) $(COUTEROBJS): $(CMODOBJS) $(ZINNEROBJS) $(ZOUTEROBJS): $(ZMODOBJS) -mld_s_inner_mod.o: mld_s_move_alloc_mod.o mld_s_prec_type.o -mld_d_inner_mod.o: mld_d_move_alloc_mod.o mld_d_prec_type.o -mld_c_inner_mod.o: mld_c_move_alloc_mod.o mld_c_prec_type.o -mld_z_inner_mod.o: mld_z_move_alloc_mod.o mld_z_prec_type.o +mld_s_inner_mod.o: mld_s_prec_type.o +mld_d_inner_mod.o: mld_d_prec_type.o +mld_c_inner_mod.o: mld_c_prec_type.o +mld_z_inner_mod.o: mld_z_prec_type.o -mld_s_move_alloc_mod.o: mld_s_prec_type.o -mld_d_move_alloc_mod.o: mld_d_prec_type.o -mld_c_move_alloc_mod.o: mld_c_prec_type.o -mld_z_move_alloc_mod.o: mld_z_prec_type.o - -mld_s_prec_mod.o: mld_s_move_alloc_mod.o -mld_d_prec_mod.o: mld_d_move_alloc_mod.o -mld_c_prec_mod.o: mld_c_move_alloc_mod.o -mld_z_prec_mod.o: mld_z_move_alloc_mod.o +mld_s_prec_mod.o: mld_s_prec_type.o +mld_d_prec_mod.o: mld_d_prec_type.o +mld_c_prec_mod.o: mld_c_prec_type.o +mld_z_prec_mod.o: mld_z_prec_type.o mld_s_prec_type.o: mld_s_onelev_mod.o @@ -97,9 +92,6 @@ mld_z_base_smoother_mod.o: mld_z_base_solver_mod.o mld_s_base_solver_mod.o mld_d_base_solver_mod.o mld_c_base_solver_mod.o mld_z_base_solver_mod.o: mld_base_prec_type.o - - - mld_d_id_solver.o mld_d_sludist_solver.o mld_d_slu_solver.o \ mld_d_umf_solver.o mld_d_diag_solver.o mld_d_ilu_solver.o: mld_d_base_solver_mod.o mld_d_prec_type.o diff --git a/mlprec/impl/mld_c_onelev_impl.f90 b/mlprec/impl/mld_c_onelev_impl.f90 index e5faa843..d25bd23f 100644 --- a/mlprec/impl/mld_c_onelev_impl.f90 +++ b/mlprec/impl/mld_c_onelev_impl.f90 @@ -154,7 +154,7 @@ subroutine mld_c_base_onelev_free(lv,info) & call lv%sm%free(info) call lv%ac%free() - if (psb_is_ok_desc(lv%desc_ac)) & + if (lv%desc_ac%is_ok()) & & call psb_cdfree(lv%desc_ac,info) call lv%map%free(info) diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index b3d6430a..a2fa21c9 100644 --- a/mlprec/impl/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -93,11 +93,13 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) ! Local Variables type(mld_cprec_type) :: t_prec - Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz + Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize integer :: ipv(mld_ifpsz_), val integer :: int_err(5) character :: upd_ - type(mld_sml_parms) :: prm + class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_sml_parms) :: baseparms, medparms, coarseparms + type(mld_c_onelev_node), pointer :: head, tail, newnode, current integer :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -145,12 +147,22 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) ! Check to ensure all procs have the same ! newsz = -1 + casize = p%coarse_aggr_size iszv = size(p%precv) call psb_bcast(ictxt,iszv) - if (iszv /= size(p%precv)) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Inconsistent size of precv') - goto 9999 + call psb_bcast(ictxt,casize) + if (casize > 0) then + if (casize /= p%coarse_aggr_size) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size') + goto 9999 + end if + else + if (iszv /= size(p%precv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of precv') + goto 9999 + end if end if if (iszv <= 1) then @@ -162,7 +174,161 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + + if (casize>0) then + ! + ! New strategy to build according to coarse size. + ! + coarseparms = p%precv(iszv)%parms + baseparms = p%precv(1)%parms + medparms = p%precv(2)%parms + + allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info) + if (info == psb_success_) & + & allocate(med_sm, source=p%precv(2)%sm,stat=info) + if (info == psb_success_) & + & allocate(base_sm, source=p%precv(1)%sm,stat=info) + if (info /= psb_success_) then + write(0,*) 'Error in saving smoothers',info + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + ! + ! Replicated matrix should only ever happen at coarse level. + ! + call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_distr_ml_coarse_mat) + ! + ! Now build a doubly linked list + ! + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + head => newnode + tail => newnode + newnode%item%base_a => a + newnode%item%base_desc => desc_a + newnode%item%parms = baseparms + newsz = 1 + current => head + list_build_loop: do + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + current%next => newnode + newnode%prev => current + newsz = newsz + 1 + newnode%item%parms = medparms + newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2 + call mld_coarse_bld(current%item%base_a, current%item%base_desc, & + & newnode%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + if (newsz>2) then + if (all(current%item%map%naggr == newnode%item%map%naggr)) then + ! + ! We are not gaining anything + ! + newsz = newsz-1 + current%next => null() + call newnode%item%free(info) + if (info == psb_success_) deallocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 + end if + end if + end if + + current => current%next + tail => current + if (sum(newnode%item%map%naggr) <= casize) then + ! + ! Target reached; but we may need to rebuild. + ! + exit list_build_loop + end if + end do list_build_loop + ! + ! At this point, we are at the list tail, + ! and it needs to be rebuilt in case the parms were + ! different. + ! + ! But the threshold has to be fixed before rebuliding + coarseparms%aggr_thresh = current%item%parms%aggr_thresh + current%item%parms = coarseparms + call mld_coarse_bld(current%prev%item%base_a,& + & current%prev%item%base_desc, & + & current%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + ! + ! Ok, now allocate the output vector and fix items. + ! + do i=1,iszv + if (info == psb_success_) call p%precv(i)%free(info) + end do + if (info == psb_success_) deallocate(p%precv,stat=info) + if (info == psb_success_) allocate(p%precv(newsz),stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 + end if + newnode => head + do i=1, newsz + current => newnode + if (info == psb_success_) & + & call mld_move_alloc(current%item,p%precv(i),info) + if (info == psb_success_) then + if (i ==1) then + allocate(p%precv(i)%sm,source=base_sm,stat=info) + else if (i < newsz) then + allocate(p%precv(i)%sm,source=med_sm,stat=info) + else + allocate(p%precv(i)%sm,source=coarse_sm,stat=info) + end if + end if + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='list cpy'); goto 9999 + end if + if (i == 1) then + p%precv(i)%base_a => a + p%precv(i)%base_desc => desc_a + else + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end if + + newnode => current%next + deallocate(current) + end do + call base_sm%free(info) + if (info == psb_success_) call med_sm%free(info) + if (info == psb_success_) call coarse_sm%free(info) + if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='final cleanup'); goto 9999 + end if + iszv = newsz + + else + ! + ! Default, oldstyle + ! ! ! Build the matrix and the transfer operators corresponding @@ -179,11 +345,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(1)%base_a => a p%precv(1)%base_desc => desc_a - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - do i=2, iszv ! @@ -201,11 +362,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) ! call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& & mld_distr_mat_,is_distr_ml_coarse_mat) - - else if (i == iszv) then - -!!$ call check_coarse_lev(p%precv(i)) - end if if (debug_level >= psb_debug_outer_) & @@ -277,9 +433,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc end do - i = iszv - call check_coarse_lev(p%precv(i)) if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& & p%precv(i-1)%base_desc, p%precv(i),info) if (info /= psb_success_) then @@ -289,6 +443,12 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) end if end if + ! + ! The coarse space hierarchy has been build. + ! + ! Now do the preconditioner build. + ! + do i=1, iszv ! ! build the base preconditioner at level i @@ -316,10 +476,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) goto 9999 end if - - ! - ! Test version for beginning of OO stuff. - ! call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold) @@ -350,69 +506,4 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) end if return -contains - - subroutine check_coarse_lev(prec) - type(mld_c_onelev_type) :: prec - - ! - ! At the coarsest level, check mld_coarse_solve_ - ! -!!$ val = prec%parms%coarse_solve -!!$ select case (val) -!!$ case(mld_jac_) -!!$ -!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ -!!$ case(mld_bjac_) -!!$ -!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.& -!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$! !$#if defined(HAVE_UMF_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_ -!!$! !$#elif defined(HAVE_SLU_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_ -!!$! !$#else -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ -!!$! !$#endif -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ -!!$ case(mld_umf_, mld_slu_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ end if -!!$ case(mld_sludist_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1 -!!$ end if -!!$ end select - end subroutine check_coarse_lev - end subroutine mld_cmlprec_bld diff --git a/mlprec/impl/mld_cprecinit.F90 b/mlprec/impl/mld_cprecinit.F90 index 2890a83f..e486f6ba 100644 --- a/mlprec/impl/mld_cprecinit.F90 +++ b/mlprec/impl/mld_cprecinit.F90 @@ -125,6 +125,7 @@ subroutine mld_cprecinit(p,ptype,info,nlev) ! Do we want to do something? endif endif + p%coarse_aggr_size = -1 select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NOPREC','NONE') diff --git a/mlprec/impl/mld_cprecset.F90 b/mlprec/impl/mld_cprecset.F90 index 167f6bc4..3d11fad2 100644 --- a/mlprec/impl/mld_cprecset.F90 +++ b/mlprec/impl/mld_cprecset.F90 @@ -129,6 +129,11 @@ subroutine mld_cprecseti(p,what,val,info,ilev) return endif + if (what == mld_coarse_aggr_size_) then + p%coarse_aggr_size = max(val,-1) + return + end if + ! ! Set preconditioner parameters at level ilev. ! diff --git a/mlprec/impl/mld_d_onelev_impl.f90 b/mlprec/impl/mld_d_onelev_impl.f90 index 46d0ccab..c83ff1de 100644 --- a/mlprec/impl/mld_d_onelev_impl.f90 +++ b/mlprec/impl/mld_d_onelev_impl.f90 @@ -154,7 +154,7 @@ subroutine mld_d_base_onelev_free(lv,info) & call lv%sm%free(info) call lv%ac%free() - if (psb_is_ok_desc(lv%desc_ac)) & + if (lv%desc_ac%is_ok()) & & call psb_cdfree(lv%desc_ac,info) call lv%map%free(info) diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index 0051fe69..94481c66 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -93,11 +93,13 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) ! Local Variables type(mld_dprec_type) :: t_prec - Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz + Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize integer :: ipv(mld_ifpsz_), val integer :: int_err(5) character :: upd_ - type(mld_dml_parms) :: prm + class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_dml_parms) :: baseparms, medparms, coarseparms + type(mld_d_onelev_node), pointer :: head, tail, newnode, current integer :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -145,12 +147,22 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) ! Check to ensure all procs have the same ! newsz = -1 + casize = p%coarse_aggr_size iszv = size(p%precv) call psb_bcast(ictxt,iszv) - if (iszv /= size(p%precv)) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Inconsistent size of precv') - goto 9999 + call psb_bcast(ictxt,casize) + if (casize > 0) then + if (casize /= p%coarse_aggr_size) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size') + goto 9999 + end if + else + if (iszv /= size(p%precv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of precv') + goto 9999 + end if end if if (iszv <= 1) then @@ -162,7 +174,161 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + + if (casize>0) then + ! + ! New strategy to build according to coarse size. + ! + coarseparms = p%precv(iszv)%parms + baseparms = p%precv(1)%parms + medparms = p%precv(2)%parms + + allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info) + if (info == psb_success_) & + & allocate(med_sm, source=p%precv(2)%sm,stat=info) + if (info == psb_success_) & + & allocate(base_sm, source=p%precv(1)%sm,stat=info) + if (info /= psb_success_) then + write(0,*) 'Error in saving smoothers',info + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + ! + ! Replicated matrix should only ever happen at coarse level. + ! + call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_distr_ml_coarse_mat) + ! + ! Now build a doubly linked list + ! + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + head => newnode + tail => newnode + newnode%item%base_a => a + newnode%item%base_desc => desc_a + newnode%item%parms = baseparms + newsz = 1 + current => head + list_build_loop: do + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + current%next => newnode + newnode%prev => current + newsz = newsz + 1 + newnode%item%parms = medparms + newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2 + call mld_coarse_bld(current%item%base_a, current%item%base_desc, & + & newnode%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + if (newsz>2) then + if (all(current%item%map%naggr == newnode%item%map%naggr)) then + ! + ! We are not gaining anything + ! + newsz = newsz-1 + current%next => null() + call newnode%item%free(info) + if (info == psb_success_) deallocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 + end if + end if + end if + + current => current%next + tail => current + if (sum(newnode%item%map%naggr) <= casize) then + ! + ! Target reached; but we may need to rebuild. + ! + exit list_build_loop + end if + end do list_build_loop + ! + ! At this point, we are at the list tail, + ! and it needs to be rebuilt in case the parms were + ! different. + ! + ! But the threshold has to be fixed before rebuliding + coarseparms%aggr_thresh = current%item%parms%aggr_thresh + current%item%parms = coarseparms + call mld_coarse_bld(current%prev%item%base_a,& + & current%prev%item%base_desc, & + & current%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + ! + ! Ok, now allocate the output vector and fix items. + ! + do i=1,iszv + if (info == psb_success_) call p%precv(i)%free(info) + end do + if (info == psb_success_) deallocate(p%precv,stat=info) + if (info == psb_success_) allocate(p%precv(newsz),stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 + end if + newnode => head + do i=1, newsz + current => newnode + if (info == psb_success_) & + & call mld_move_alloc(current%item,p%precv(i),info) + if (info == psb_success_) then + if (i ==1) then + allocate(p%precv(i)%sm,source=base_sm,stat=info) + else if (i < newsz) then + allocate(p%precv(i)%sm,source=med_sm,stat=info) + else + allocate(p%precv(i)%sm,source=coarse_sm,stat=info) + end if + end if + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='list cpy'); goto 9999 + end if + if (i == 1) then + p%precv(i)%base_a => a + p%precv(i)%base_desc => desc_a + else + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end if + + newnode => current%next + deallocate(current) + end do + call base_sm%free(info) + if (info == psb_success_) call med_sm%free(info) + if (info == psb_success_) call coarse_sm%free(info) + if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='final cleanup'); goto 9999 + end if + iszv = newsz + + else + ! + ! Default, oldstyle + ! ! ! Build the matrix and the transfer operators corresponding @@ -179,11 +345,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(1)%base_a => a p%precv(1)%base_desc => desc_a - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - do i=2, iszv ! @@ -201,11 +362,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) ! call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& & mld_distr_mat_,is_distr_ml_coarse_mat) - - else if (i == iszv) then - -!!$ call check_coarse_lev(p%precv(i)) - end if if (debug_level >= psb_debug_outer_) & @@ -277,9 +433,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc end do - i = iszv - call check_coarse_lev(p%precv(i)) if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& & p%precv(i-1)%base_desc, p%precv(i),info) if (info /= psb_success_) then @@ -289,6 +443,12 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) end if end if + ! + ! The coarse space hierarchy has been build. + ! + ! Now do the preconditioner build. + ! + do i=1, iszv ! ! build the base preconditioner at level i @@ -316,10 +476,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) goto 9999 end if - - ! - ! Test version for beginning of OO stuff. - ! call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold) @@ -350,69 +506,4 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) end if return -contains - - subroutine check_coarse_lev(prec) - type(mld_d_onelev_type) :: prec - - ! - ! At the coarsest level, check mld_coarse_solve_ - ! -!!$ val = prec%parms%coarse_solve -!!$ select case (val) -!!$ case(mld_jac_) -!!$ -!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ -!!$ case(mld_bjac_) -!!$ -!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.& -!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$! !$#if defined(HAVE_UMF_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_ -!!$! !$#elif defined(HAVE_SLU_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_ -!!$! !$#else -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ -!!$! !$#endif -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ -!!$ case(mld_umf_, mld_slu_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ end if -!!$ case(mld_sludist_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1 -!!$ end if -!!$ end select - end subroutine check_coarse_lev - end subroutine mld_dmlprec_bld diff --git a/mlprec/impl/mld_s_onelev_impl.f90 b/mlprec/impl/mld_s_onelev_impl.f90 index 18cc7154..3a5d9d68 100644 --- a/mlprec/impl/mld_s_onelev_impl.f90 +++ b/mlprec/impl/mld_s_onelev_impl.f90 @@ -154,7 +154,7 @@ subroutine mld_s_base_onelev_free(lv,info) & call lv%sm%free(info) call lv%ac%free() - if (psb_is_ok_desc(lv%desc_ac)) & + if (lv%desc_ac%is_ok()) & & call psb_cdfree(lv%desc_ac,info) call lv%map%free(info) diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index d49576d6..de9e23fe 100644 --- a/mlprec/impl/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -93,11 +93,13 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) ! Local Variables type(mld_sprec_type) :: t_prec - Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz + Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize integer :: ipv(mld_ifpsz_), val integer :: int_err(5) character :: upd_ - type(mld_sml_parms) :: prm + class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_sml_parms) :: baseparms, medparms, coarseparms + type(mld_s_onelev_node), pointer :: head, tail, newnode, current integer :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -145,12 +147,22 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) ! Check to ensure all procs have the same ! newsz = -1 + casize = p%coarse_aggr_size iszv = size(p%precv) call psb_bcast(ictxt,iszv) - if (iszv /= size(p%precv)) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Inconsistent size of precv') - goto 9999 + call psb_bcast(ictxt,casize) + if (casize > 0) then + if (casize /= p%coarse_aggr_size) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size') + goto 9999 + end if + else + if (iszv /= size(p%precv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of precv') + goto 9999 + end if end if if (iszv <= 1) then @@ -162,7 +174,161 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + + if (casize>0) then + ! + ! New strategy to build according to coarse size. + ! + coarseparms = p%precv(iszv)%parms + baseparms = p%precv(1)%parms + medparms = p%precv(2)%parms + + allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info) + if (info == psb_success_) & + & allocate(med_sm, source=p%precv(2)%sm,stat=info) + if (info == psb_success_) & + & allocate(base_sm, source=p%precv(1)%sm,stat=info) + if (info /= psb_success_) then + write(0,*) 'Error in saving smoothers',info + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + ! + ! Replicated matrix should only ever happen at coarse level. + ! + call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_distr_ml_coarse_mat) + ! + ! Now build a doubly linked list + ! + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + head => newnode + tail => newnode + newnode%item%base_a => a + newnode%item%base_desc => desc_a + newnode%item%parms = baseparms + newsz = 1 + current => head + list_build_loop: do + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + current%next => newnode + newnode%prev => current + newsz = newsz + 1 + newnode%item%parms = medparms + newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2 + call mld_coarse_bld(current%item%base_a, current%item%base_desc, & + & newnode%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + if (newsz>2) then + if (all(current%item%map%naggr == newnode%item%map%naggr)) then + ! + ! We are not gaining anything + ! + newsz = newsz-1 + current%next => null() + call newnode%item%free(info) + if (info == psb_success_) deallocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 + end if + end if + end if + + current => current%next + tail => current + if (sum(newnode%item%map%naggr) <= casize) then + ! + ! Target reached; but we may need to rebuild. + ! + exit list_build_loop + end if + end do list_build_loop + ! + ! At this point, we are at the list tail, + ! and it needs to be rebuilt in case the parms were + ! different. + ! + ! But the threshold has to be fixed before rebuliding + coarseparms%aggr_thresh = current%item%parms%aggr_thresh + current%item%parms = coarseparms + call mld_coarse_bld(current%prev%item%base_a,& + & current%prev%item%base_desc, & + & current%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + ! + ! Ok, now allocate the output vector and fix items. + ! + do i=1,iszv + if (info == psb_success_) call p%precv(i)%free(info) + end do + if (info == psb_success_) deallocate(p%precv,stat=info) + if (info == psb_success_) allocate(p%precv(newsz),stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 + end if + newnode => head + do i=1, newsz + current => newnode + if (info == psb_success_) & + & call mld_move_alloc(current%item,p%precv(i),info) + if (info == psb_success_) then + if (i ==1) then + allocate(p%precv(i)%sm,source=base_sm,stat=info) + else if (i < newsz) then + allocate(p%precv(i)%sm,source=med_sm,stat=info) + else + allocate(p%precv(i)%sm,source=coarse_sm,stat=info) + end if + end if + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='list cpy'); goto 9999 + end if + if (i == 1) then + p%precv(i)%base_a => a + p%precv(i)%base_desc => desc_a + else + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end if + + newnode => current%next + deallocate(current) + end do + call base_sm%free(info) + if (info == psb_success_) call med_sm%free(info) + if (info == psb_success_) call coarse_sm%free(info) + if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='final cleanup'); goto 9999 + end if + iszv = newsz + + else + ! + ! Default, oldstyle + ! ! ! Build the matrix and the transfer operators corresponding @@ -179,11 +345,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(1)%base_a => a p%precv(1)%base_desc => desc_a - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - do i=2, iszv ! @@ -201,11 +362,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) ! call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& & mld_distr_mat_,is_distr_ml_coarse_mat) - - else if (i == iszv) then - -!!$ call check_coarse_lev(p%precv(i)) - end if if (debug_level >= psb_debug_outer_) & @@ -277,9 +433,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc end do - i = iszv - call check_coarse_lev(p%precv(i)) if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& & p%precv(i-1)%base_desc, p%precv(i),info) if (info /= psb_success_) then @@ -289,6 +443,12 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) end if end if + ! + ! The coarse space hierarchy has been build. + ! + ! Now do the preconditioner build. + ! + do i=1, iszv ! ! build the base preconditioner at level i @@ -316,10 +476,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) goto 9999 end if - - ! - ! Test version for beginning of OO stuff. - ! call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold) @@ -350,69 +506,4 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) end if return -contains - - subroutine check_coarse_lev(prec) - type(mld_s_onelev_type) :: prec - - ! - ! At the coarsest level, check mld_coarse_solve_ - ! -!!$ val = prec%parms%coarse_solve -!!$ select case (val) -!!$ case(mld_jac_) -!!$ -!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ -!!$ case(mld_bjac_) -!!$ -!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.& -!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$! !$#if defined(HAVE_UMF_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_ -!!$! !$#elif defined(HAVE_SLU_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_ -!!$! !$#else -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ -!!$! !$#endif -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ -!!$ case(mld_umf_, mld_slu_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ end if -!!$ case(mld_sludist_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1 -!!$ end if -!!$ end select - end subroutine check_coarse_lev - end subroutine mld_smlprec_bld diff --git a/mlprec/impl/mld_sprecinit.F90 b/mlprec/impl/mld_sprecinit.F90 index 12d10d9e..d8b66f83 100644 --- a/mlprec/impl/mld_sprecinit.F90 +++ b/mlprec/impl/mld_sprecinit.F90 @@ -125,6 +125,7 @@ subroutine mld_sprecinit(p,ptype,info,nlev) ! Do we want to do something? endif endif + p%coarse_aggr_size = -1 select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NOPREC','NONE') diff --git a/mlprec/impl/mld_sprecset.F90 b/mlprec/impl/mld_sprecset.F90 index 0c8f3fa6..895e5b89 100644 --- a/mlprec/impl/mld_sprecset.F90 +++ b/mlprec/impl/mld_sprecset.F90 @@ -129,6 +129,11 @@ subroutine mld_sprecseti(p,what,val,info,ilev) return endif + if (what == mld_coarse_aggr_size_) then + p%coarse_aggr_size = max(val,-1) + return + end if + ! ! Set preconditioner parameters at level ilev. ! diff --git a/mlprec/impl/mld_z_onelev_impl.f90 b/mlprec/impl/mld_z_onelev_impl.f90 index 1bdc04de..68f20bab 100644 --- a/mlprec/impl/mld_z_onelev_impl.f90 +++ b/mlprec/impl/mld_z_onelev_impl.f90 @@ -154,7 +154,7 @@ subroutine mld_z_base_onelev_free(lv,info) & call lv%sm%free(info) call lv%ac%free() - if (psb_is_ok_desc(lv%desc_ac)) & + if (lv%desc_ac%is_ok()) & & call psb_cdfree(lv%desc_ac,info) call lv%map%free(info) diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index 8f1a949a..24341f9b 100644 --- a/mlprec/impl/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -93,11 +93,13 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) ! Local Variables type(mld_zprec_type) :: t_prec - Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz + Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize integer :: ipv(mld_ifpsz_), val integer :: int_err(5) character :: upd_ - type(mld_dml_parms) :: prm + class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_dml_parms) :: baseparms, medparms, coarseparms + type(mld_z_onelev_node), pointer :: head, tail, newnode, current integer :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -145,12 +147,22 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) ! Check to ensure all procs have the same ! newsz = -1 + casize = p%coarse_aggr_size iszv = size(p%precv) call psb_bcast(ictxt,iszv) - if (iszv /= size(p%precv)) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Inconsistent size of precv') - goto 9999 + call psb_bcast(ictxt,casize) + if (casize > 0) then + if (casize /= p%coarse_aggr_size) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size') + goto 9999 + end if + else + if (iszv /= size(p%precv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of precv') + goto 9999 + end if end if if (iszv <= 1) then @@ -162,7 +174,161 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + + if (casize>0) then + ! + ! New strategy to build according to coarse size. + ! + coarseparms = p%precv(iszv)%parms + baseparms = p%precv(1)%parms + medparms = p%precv(2)%parms + + allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info) + if (info == psb_success_) & + & allocate(med_sm, source=p%precv(2)%sm,stat=info) + if (info == psb_success_) & + & allocate(base_sm, source=p%precv(1)%sm,stat=info) + if (info /= psb_success_) then + write(0,*) 'Error in saving smoothers',info + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + ! + ! Replicated matrix should only ever happen at coarse level. + ! + call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_distr_ml_coarse_mat) + ! + ! Now build a doubly linked list + ! + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + head => newnode + tail => newnode + newnode%item%base_a => a + newnode%item%base_desc => desc_a + newnode%item%parms = baseparms + newsz = 1 + current => head + list_build_loop: do + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + current%next => newnode + newnode%prev => current + newsz = newsz + 1 + newnode%item%parms = medparms + newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2 + call mld_coarse_bld(current%item%base_a, current%item%base_desc, & + & newnode%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + if (newsz>2) then + if (all(current%item%map%naggr == newnode%item%map%naggr)) then + ! + ! We are not gaining anything + ! + newsz = newsz-1 + current%next => null() + call newnode%item%free(info) + if (info == psb_success_) deallocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 + end if + end if + end if + + current => current%next + tail => current + if (sum(newnode%item%map%naggr) <= casize) then + ! + ! Target reached; but we may need to rebuild. + ! + exit list_build_loop + end if + end do list_build_loop + ! + ! At this point, we are at the list tail, + ! and it needs to be rebuilt in case the parms were + ! different. + ! + ! But the threshold has to be fixed before rebuliding + coarseparms%aggr_thresh = current%item%parms%aggr_thresh + current%item%parms = coarseparms + call mld_coarse_bld(current%prev%item%base_a,& + & current%prev%item%base_desc, & + & current%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + ! + ! Ok, now allocate the output vector and fix items. + ! + do i=1,iszv + if (info == psb_success_) call p%precv(i)%free(info) + end do + if (info == psb_success_) deallocate(p%precv,stat=info) + if (info == psb_success_) allocate(p%precv(newsz),stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 + end if + newnode => head + do i=1, newsz + current => newnode + if (info == psb_success_) & + & call mld_move_alloc(current%item,p%precv(i),info) + if (info == psb_success_) then + if (i ==1) then + allocate(p%precv(i)%sm,source=base_sm,stat=info) + else if (i < newsz) then + allocate(p%precv(i)%sm,source=med_sm,stat=info) + else + allocate(p%precv(i)%sm,source=coarse_sm,stat=info) + end if + end if + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='list cpy'); goto 9999 + end if + if (i == 1) then + p%precv(i)%base_a => a + p%precv(i)%base_desc => desc_a + else + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end if + + newnode => current%next + deallocate(current) + end do + call base_sm%free(info) + if (info == psb_success_) call med_sm%free(info) + if (info == psb_success_) call coarse_sm%free(info) + if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='final cleanup'); goto 9999 + end if + iszv = newsz + + else + ! + ! Default, oldstyle + ! ! ! Build the matrix and the transfer operators corresponding @@ -179,11 +345,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(1)%base_a => a p%precv(1)%base_desc => desc_a - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - do i=2, iszv ! @@ -201,11 +362,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) ! call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& & mld_distr_mat_,is_distr_ml_coarse_mat) - - else if (i == iszv) then - -!!$ call check_coarse_lev(p%precv(i)) - end if if (debug_level >= psb_debug_outer_) & @@ -277,9 +433,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc end do - i = iszv - call check_coarse_lev(p%precv(i)) if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& & p%precv(i-1)%base_desc, p%precv(i),info) if (info /= psb_success_) then @@ -289,6 +443,12 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) end if end if + ! + ! The coarse space hierarchy has been build. + ! + ! Now do the preconditioner build. + ! + do i=1, iszv ! ! build the base preconditioner at level i @@ -316,10 +476,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) goto 9999 end if - - ! - ! Test version for beginning of OO stuff. - ! call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold) @@ -350,69 +506,4 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) end if return -contains - - subroutine check_coarse_lev(prec) - type(mld_z_onelev_type) :: prec - - ! - ! At the coarsest level, check mld_coarse_solve_ - ! -!!$ val = prec%parms%coarse_solve -!!$ select case (val) -!!$ case(mld_jac_) -!!$ -!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ -!!$ case(mld_bjac_) -!!$ -!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.& -!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$! !$#if defined(HAVE_UMF_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_ -!!$! !$#elif defined(HAVE_SLU_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_ -!!$! !$#else -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ -!!$! !$#endif -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ -!!$ case(mld_umf_, mld_slu_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ end if -!!$ case(mld_sludist_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1 -!!$ end if -!!$ end select - end subroutine check_coarse_lev - end subroutine mld_zmlprec_bld diff --git a/mlprec/impl/mld_zprecinit.F90 b/mlprec/impl/mld_zprecinit.F90 index 1bf0f172..b5cd4a0e 100644 --- a/mlprec/impl/mld_zprecinit.F90 +++ b/mlprec/impl/mld_zprecinit.F90 @@ -125,6 +125,7 @@ subroutine mld_zprecinit(p,ptype,info,nlev) ! Do we want to do something? endif endif + p%coarse_aggr_size = -1 select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NOPREC','NONE') diff --git a/mlprec/impl/mld_zprecset.F90 b/mlprec/impl/mld_zprecset.F90 index c49244ac..cd1bfb1d 100644 --- a/mlprec/impl/mld_zprecset.F90 +++ b/mlprec/impl/mld_zprecset.F90 @@ -129,6 +129,11 @@ subroutine mld_zprecseti(p,what,val,info,ilev) return endif + if (what == mld_coarse_aggr_size_) then + p%coarse_aggr_size = max(val,-1) + return + end if + ! ! Set preconditioner parameters at level ilev. ! diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 83de58d5..f5d2caa3 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -104,6 +104,7 @@ module mld_base_prec_type procedure, pass(pm) :: descr => ml_parms_descr procedure, pass(pm) :: mldescr => ml_parms_mldescr procedure, pass(pm) :: coarsedescr => ml_parms_coarsedescr + procedure, pass(pm) :: printout => ml_parms_printout end type mld_ml_parms @@ -111,12 +112,14 @@ module mld_base_prec_type real(psb_spk_) :: aggr_omega_val, aggr_thresh contains procedure, pass(pm) :: descr => s_ml_parms_descr + procedure, pass(pm) :: printout => s_ml_parms_printout end type mld_sml_parms type, extends(mld_ml_parms) :: mld_dml_parms real(psb_dpk_) :: aggr_omega_val, aggr_thresh contains procedure, pass(pm) :: descr => d_ml_parms_descr + procedure, pass(pm) :: printout => d_ml_parms_printout end type mld_dml_parms @@ -437,6 +440,40 @@ contains end subroutine mld_stringval + + subroutine ml_parms_printout(pm,iout) + implicit none + class(mld_ml_parms), intent(in) :: pm + integer, intent(in) :: iout + + write(iout,*) 'Sweeps: ',pm%sweeps,pm%sweeps_pre,pm%sweeps_post + write(iout,*) 'ML : ',pm%ml_type,pm%smoother_pos + write(iout,*) 'AGGR : ',pm%aggr_alg,pm%aggr_kind + write(iout,*) ' : ',pm%aggr_omega_alg,pm%aggr_eig,pm%aggr_filter + write(iout,*) 'COARSE: ',pm%coarse_mat,pm%coarse_solve + end subroutine ml_parms_printout + + + subroutine s_ml_parms_printout(pm,iout) + implicit none + class(mld_sml_parms), intent(in) :: pm + integer, intent(in) :: iout + + call pm%mld_ml_parms%printout(iout) + write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh + end subroutine s_ml_parms_printout + + + subroutine d_ml_parms_printout(pm,iout) + implicit none + class(mld_dml_parms), intent(in) :: pm + integer, intent(in) :: iout + + call pm%mld_ml_parms%printout(iout) + write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh + end subroutine d_ml_parms_printout + + ! ! Routines printing out a description of the preconditioner ! diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 8cf313d0..5ff82c70 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -46,8 +46,6 @@ ! module mld_c_inner_mod use mld_c_prec_type - use mld_c_move_alloc_mod - interface mld_mlprec_bld subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold) diff --git a/mlprec/mld_c_move_alloc_mod.f90 b/mlprec/mld_c_move_alloc_mod.f90 index 85f8120b..d936c0fd 100644 --- a/mlprec/mld_c_move_alloc_mod.f90 +++ b/mlprec/mld_c_move_alloc_mod.f90 @@ -62,6 +62,7 @@ contains integer, intent(out) :: info call b%free(info) + b%parms = a%parms call move_alloc(a%sm,b%sm) if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index ba329fb7..2f9d30a2 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -141,6 +141,11 @@ module mld_c_onelev_mod procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros end type mld_c_onelev_type + type mld_c_onelev_node + type(mld_c_onelev_type) :: item + type(mld_c_onelev_node), pointer :: prev=>null(), next=>null() + end type mld_c_onelev_node + private :: c_base_onelev_default, c_base_onelev_sizeof, & & c_base_onelev_nullify, c_base_onelev_get_nzeros @@ -234,6 +239,9 @@ module mld_c_onelev_mod end subroutine mld_c_base_onelev_dump end interface + interface mld_move_alloc + module procedure mld_c_onelev_move_alloc + end interface contains ! @@ -312,4 +320,22 @@ contains end subroutine c_base_onelev_default + + subroutine mld_c_onelev_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_c_onelev_type), intent(inout) :: a, b + integer, intent(out) :: info + + call b%free(info) + b%parms = a%parms + call move_alloc(a%sm,b%sm) + if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) + b%base_a => a%base_a + b%base_desc => a%base_desc + + end subroutine mld_c_onelev_move_alloc + end module mld_c_onelev_mod diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index 142a6d93..52f0ad8c 100644 --- a/mlprec/mld_c_prec_mod.f90 +++ b/mlprec/mld_c_prec_mod.f90 @@ -46,7 +46,6 @@ module mld_c_prec_mod use mld_c_prec_type - use mld_c_move_alloc_mod interface mld_precinit subroutine mld_cprecinit(p,ptype,info,nlev) diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index a39eef0b..690def55 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -81,6 +81,7 @@ module mld_c_prec_type type, extends(psb_cprec_type) :: mld_cprec_type integer :: ictxt + integer(psb_ipk_) :: coarse_aggr_size real(psb_spk_) :: op_complexity=szero type(mld_c_onelev_type), allocatable :: precv(:) contains @@ -159,6 +160,10 @@ module mld_c_prec_type end subroutine mld_cprecaply1 end interface + interface mld_move_alloc + module procedure mld_cprec_move_alloc + end interface + contains ! ! Function returning the size of the mld_prec_type data structure @@ -565,7 +570,7 @@ contains if (present(istart)) then il1 = max(1,istart) else - il1 = 2 + il1 = min(2,iln) end if if (present(iend)) then iln = min(iln, iend) @@ -577,5 +582,32 @@ contains end do end subroutine mld_c_dump + + subroutine mld_cprec_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_cprec_type), intent(inout) :: a + type(mld_cprec_type), intent(inout), target :: b + integer, intent(out) :: info + integer :: i + + if (allocated(b%precv)) then + ! This might not be required if FINAL procedures are available. + call mld_precfree(b,info) + if (info /= psb_success_) then + ! ????? + !!$ return + endif + end if + + call move_alloc(a%precv,b%precv) + ! Fix the pointers except on level 1. + do i=2, size(b%precv) + b%precv(i)%base_a => b%precv(i)%ac + b%precv(i)%base_desc => b%precv(i)%desc_ac + b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc + b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc + end do + end subroutine mld_cprec_move_alloc end module mld_c_prec_type diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index b07aec6c..5b8a2979 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -46,8 +46,6 @@ ! module mld_d_inner_mod use mld_d_prec_type - use mld_d_move_alloc_mod - interface mld_mlprec_bld subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold) diff --git a/mlprec/mld_d_move_alloc_mod.f90 b/mlprec/mld_d_move_alloc_mod.f90 index d7bc7f1e..27f26fee 100644 --- a/mlprec/mld_d_move_alloc_mod.f90 +++ b/mlprec/mld_d_move_alloc_mod.f90 @@ -62,6 +62,7 @@ contains integer, intent(out) :: info call b%free(info) + b%parms = a%parms call move_alloc(a%sm,b%sm) if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index a17a0333..a5689a69 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -141,6 +141,11 @@ module mld_d_onelev_mod procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros end type mld_d_onelev_type + type mld_d_onelev_node + type(mld_d_onelev_type) :: item + type(mld_d_onelev_node), pointer :: prev=>null(), next=>null() + end type mld_d_onelev_node + private :: d_base_onelev_default, d_base_onelev_sizeof, & & d_base_onelev_nullify, d_base_onelev_get_nzeros @@ -234,6 +239,9 @@ module mld_d_onelev_mod end subroutine mld_d_base_onelev_dump end interface + interface mld_move_alloc + module procedure mld_d_onelev_move_alloc + end interface contains ! @@ -312,4 +320,22 @@ contains end subroutine d_base_onelev_default + + subroutine mld_d_onelev_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_d_onelev_type), intent(inout) :: a, b + integer, intent(out) :: info + + call b%free(info) + b%parms = a%parms + call move_alloc(a%sm,b%sm) + if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) + b%base_a => a%base_a + b%base_desc => a%base_desc + + end subroutine mld_d_onelev_move_alloc + end module mld_d_onelev_mod diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index a4006aca..34231e12 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -46,7 +46,6 @@ module mld_d_prec_mod use mld_d_prec_type - use mld_d_move_alloc_mod interface mld_precinit subroutine mld_dprecinit(p,ptype,info,nlev) diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index 86ba03f2..296751c5 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -81,7 +81,7 @@ module mld_d_prec_type type, extends(psb_dprec_type) :: mld_dprec_type integer :: ictxt - integer :: coarse_aggr_size + integer(psb_ipk_) :: coarse_aggr_size real(psb_dpk_) :: op_complexity=dzero type(mld_d_onelev_type), allocatable :: precv(:) contains @@ -160,6 +160,10 @@ module mld_d_prec_type end subroutine mld_dprecaply1 end interface + interface mld_move_alloc + module procedure mld_dprec_move_alloc + end interface + contains ! ! Function returning the size of the mld_prec_type data structure @@ -566,7 +570,7 @@ contains if (present(istart)) then il1 = max(1,istart) else - il1 = 2 + il1 = min(2,iln) end if if (present(iend)) then iln = min(iln, iend) @@ -578,5 +582,32 @@ contains end do end subroutine mld_d_dump + + subroutine mld_dprec_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_dprec_type), intent(inout) :: a + type(mld_dprec_type), intent(inout), target :: b + integer, intent(out) :: info + integer :: i + + if (allocated(b%precv)) then + ! This might not be required if FINAL procedures are available. + call mld_precfree(b,info) + if (info /= psb_success_) then + ! ????? + !!$ return + endif + end if + + call move_alloc(a%precv,b%precv) + ! Fix the pointers except on level 1. + do i=2, size(b%precv) + b%precv(i)%base_a => b%precv(i)%ac + b%precv(i)%base_desc => b%precv(i)%desc_ac + b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc + b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc + end do + end subroutine mld_dprec_move_alloc end module mld_d_prec_type diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index db48e913..b09fa587 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -46,8 +46,6 @@ ! module mld_s_inner_mod use mld_s_prec_type - use mld_s_move_alloc_mod - interface mld_mlprec_bld subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold) diff --git a/mlprec/mld_s_move_alloc_mod.f90 b/mlprec/mld_s_move_alloc_mod.f90 index d23fefe9..07676612 100644 --- a/mlprec/mld_s_move_alloc_mod.f90 +++ b/mlprec/mld_s_move_alloc_mod.f90 @@ -62,6 +62,7 @@ contains integer, intent(out) :: info call b%free(info) + b%parms = a%parms call move_alloc(a%sm,b%sm) if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index 17f69512..890467c2 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -141,6 +141,11 @@ module mld_s_onelev_mod procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros end type mld_s_onelev_type + type mld_s_onelev_node + type(mld_s_onelev_type) :: item + type(mld_s_onelev_node), pointer :: prev=>null(), next=>null() + end type mld_s_onelev_node + private :: s_base_onelev_default, s_base_onelev_sizeof, & & s_base_onelev_nullify, s_base_onelev_get_nzeros @@ -234,6 +239,9 @@ module mld_s_onelev_mod end subroutine mld_s_base_onelev_dump end interface + interface mld_move_alloc + module procedure mld_s_onelev_move_alloc + end interface contains ! @@ -312,4 +320,22 @@ contains end subroutine s_base_onelev_default + + subroutine mld_s_onelev_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_s_onelev_type), intent(inout) :: a, b + integer, intent(out) :: info + + call b%free(info) + b%parms = a%parms + call move_alloc(a%sm,b%sm) + if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) + b%base_a => a%base_a + b%base_desc => a%base_desc + + end subroutine mld_s_onelev_move_alloc + end module mld_s_onelev_mod diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index f67c0df6..22981b22 100644 --- a/mlprec/mld_s_prec_mod.f90 +++ b/mlprec/mld_s_prec_mod.f90 @@ -46,7 +46,6 @@ module mld_s_prec_mod use mld_s_prec_type - use mld_s_move_alloc_mod interface mld_precinit subroutine mld_sprecinit(p,ptype,info,nlev) diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 5972a517..da4cc788 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -81,6 +81,7 @@ module mld_s_prec_type type, extends(psb_sprec_type) :: mld_sprec_type integer :: ictxt + integer(psb_ipk_) :: coarse_aggr_size real(psb_spk_) :: op_complexity=szero type(mld_s_onelev_type), allocatable :: precv(:) contains @@ -159,6 +160,10 @@ module mld_s_prec_type end subroutine mld_sprecaply1 end interface + interface mld_move_alloc + module procedure mld_sprec_move_alloc + end interface + contains ! ! Function returning the size of the mld_prec_type data structure @@ -565,7 +570,7 @@ contains if (present(istart)) then il1 = max(1,istart) else - il1 = 2 + il1 = min(2,iln) end if if (present(iend)) then iln = min(iln, iend) @@ -577,5 +582,32 @@ contains end do end subroutine mld_s_dump + + subroutine mld_sprec_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_sprec_type), intent(inout) :: a + type(mld_sprec_type), intent(inout), target :: b + integer, intent(out) :: info + integer :: i + + if (allocated(b%precv)) then + ! This might not be required if FINAL procedures are available. + call mld_precfree(b,info) + if (info /= psb_success_) then + ! ????? + !!$ return + endif + end if + + call move_alloc(a%precv,b%precv) + ! Fix the pointers except on level 1. + do i=2, size(b%precv) + b%precv(i)%base_a => b%precv(i)%ac + b%precv(i)%base_desc => b%precv(i)%desc_ac + b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc + b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc + end do + end subroutine mld_sprec_move_alloc end module mld_s_prec_type diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index 4b05ceb8..2428a3ec 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -46,8 +46,6 @@ ! module mld_z_inner_mod use mld_z_prec_type - use mld_z_move_alloc_mod - interface mld_mlprec_bld subroutine mld_zmlprec_bld(a,desc_a,prec,info, amold, vmold) diff --git a/mlprec/mld_z_move_alloc_mod.f90 b/mlprec/mld_z_move_alloc_mod.f90 index 098d763a..59be7ece 100644 --- a/mlprec/mld_z_move_alloc_mod.f90 +++ b/mlprec/mld_z_move_alloc_mod.f90 @@ -62,6 +62,7 @@ contains integer, intent(out) :: info call b%free(info) + b%parms = a%parms call move_alloc(a%sm,b%sm) if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index 6dfed8c2..3e2e7da2 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -141,6 +141,11 @@ module mld_z_onelev_mod procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros end type mld_z_onelev_type + type mld_z_onelev_node + type(mld_z_onelev_type) :: item + type(mld_z_onelev_node), pointer :: prev=>null(), next=>null() + end type mld_z_onelev_node + private :: z_base_onelev_default, z_base_onelev_sizeof, & & z_base_onelev_nullify, z_base_onelev_get_nzeros @@ -234,6 +239,9 @@ module mld_z_onelev_mod end subroutine mld_z_base_onelev_dump end interface + interface mld_move_alloc + module procedure mld_z_onelev_move_alloc + end interface contains ! @@ -312,4 +320,22 @@ contains end subroutine z_base_onelev_default + + subroutine mld_z_onelev_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_z_onelev_type), intent(inout) :: a, b + integer, intent(out) :: info + + call b%free(info) + b%parms = a%parms + call move_alloc(a%sm,b%sm) + if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) + b%base_a => a%base_a + b%base_desc => a%base_desc + + end subroutine mld_z_onelev_move_alloc + end module mld_z_onelev_mod diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index 0ec94a43..542aa12a 100644 --- a/mlprec/mld_z_prec_mod.f90 +++ b/mlprec/mld_z_prec_mod.f90 @@ -46,7 +46,6 @@ module mld_z_prec_mod use mld_z_prec_type - use mld_z_move_alloc_mod interface mld_precinit subroutine mld_zprecinit(p,ptype,info,nlev) diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index cd29b8af..f910d7ba 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -81,6 +81,7 @@ module mld_z_prec_type type, extends(psb_zprec_type) :: mld_zprec_type integer :: ictxt + integer(psb_ipk_) :: coarse_aggr_size real(psb_dpk_) :: op_complexity=dzero type(mld_z_onelev_type), allocatable :: precv(:) contains @@ -159,6 +160,10 @@ module mld_z_prec_type end subroutine mld_zprecaply1 end interface + interface mld_move_alloc + module procedure mld_zprec_move_alloc + end interface + contains ! ! Function returning the size of the mld_prec_type data structure @@ -565,7 +570,7 @@ contains if (present(istart)) then il1 = max(1,istart) else - il1 = 2 + il1 = min(2,iln) end if if (present(iend)) then iln = min(iln, iend) @@ -577,5 +582,32 @@ contains end do end subroutine mld_z_dump + + subroutine mld_zprec_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_zprec_type), intent(inout) :: a + type(mld_zprec_type), intent(inout), target :: b + integer, intent(out) :: info + integer :: i + + if (allocated(b%precv)) then + ! This might not be required if FINAL procedures are available. + call mld_precfree(b,info) + if (info /= psb_success_) then + ! ????? + !!$ return + endif + end if + + call move_alloc(a%precv,b%precv) + ! Fix the pointers except on level 1. + do i=2, size(b%precv) + b%precv(i)%base_a => b%precv(i)%ac + b%precv(i)%base_desc => b%precv(i)%desc_ac + b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc + b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc + end do + end subroutine mld_zprec_move_alloc end module mld_z_prec_type diff --git a/tests/pdegen/ppde2d.f90 b/tests/pdegen/ppde2d.f90 index 69fc77e6..d3d8e95d 100644 --- a/tests/pdegen/ppde2d.f90 +++ b/tests/pdegen/ppde2d.f90 @@ -110,6 +110,7 @@ program ppde2d character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing + integer :: csize ! aggregation size at which to stop. character(len=16) :: cmat ! coarse mat character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. @@ -196,6 +197,7 @@ program ppde2d call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info) else nlv = 1 call mld_precinit(prec,prectype%prec, info, nlev=nlv) @@ -336,6 +338,7 @@ contains call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%athres,5) ! smoother aggr thresh + call read_data(prectype%csize,5) ! coarse size end if end if @@ -373,6 +376,7 @@ contains call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + call psb_bcast(ictxt,prectype%csize) ! coarse size end if if (iam == psb_root_) then diff --git a/tests/pdegen/ppde3d.f90 b/tests/pdegen/ppde3d.f90 index db96119c..dfeebc3a 100644 --- a/tests/pdegen/ppde3d.f90 +++ b/tests/pdegen/ppde3d.f90 @@ -111,6 +111,7 @@ program ppde3d character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing + integer :: csize ! aggregation size at which to stop. character(len=16) :: cmat ! coarse mat character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. @@ -200,6 +201,7 @@ program ppde3d call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info) else nlv = 1 call mld_precinit(prec,prectype%prec, info, nlev=nlv) @@ -340,6 +342,7 @@ contains call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%athres,5) ! smoother aggr thresh + call read_data(prectype%csize,5) ! coarse size end if end if @@ -377,6 +380,7 @@ contains call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + call psb_bcast(ictxt,prectype%csize) ! coarse size end if if (iam == psb_root_) then diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 4e674318..464d1c02 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,6 +1,6 @@ BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD -040 ! IDIM; domain size is idim**3 +100 ! IDIM; domain size is idim**3 2 ! ISTOPC 0100 ! ITMAX -1 ! ITRACE @@ -21,10 +21,11 @@ NONSMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED DEC ! Type of aggregation DEC SYMDEC GLB MULT ! Type of multilevel correction: ADD MULT TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) -DIST ! Coarse level: matrix distribution DIST REPL +REPL ! Coarse level: matrix distribution DIST REPL BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST ILU ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST 1 ! Coarse level: Level-set N for ILU(N) 1.d-4 ! Coarse level: Threshold T for ILU(T,P) 4 ! Coarse level: Number of Jacobi sweeps -0.10d0 ! Smoother Aggregation Threshold: >= 0.0 default if <0 +100 ! Coarse size limit to determine levels. If <0, then use NL diff --git a/tests/pdegen/spde2d.f90 b/tests/pdegen/spde2d.f90 index aca14652..b0e5147d 100644 --- a/tests/pdegen/spde2d.f90 +++ b/tests/pdegen/spde2d.f90 @@ -110,6 +110,7 @@ program spde2d character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing + integer :: csize ! aggregation size at which to stop. character(len=16) :: cmat ! coarse mat character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. @@ -196,6 +197,7 @@ program spde2d call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info) else nlv = 1 call mld_precinit(prec,prectype%prec, info, nlev=nlv) @@ -336,6 +338,7 @@ contains call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%athres,5) ! smoother aggr thresh + call read_data(prectype%csize,5) ! coarse size end if end if @@ -373,6 +376,7 @@ contains call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + call psb_bcast(ictxt,prectype%csize) ! coarse size end if if (iam == psb_root_) then diff --git a/tests/pdegen/spde3d.f90 b/tests/pdegen/spde3d.f90 index 32b12f88..8d2ab5c4 100644 --- a/tests/pdegen/spde3d.f90 +++ b/tests/pdegen/spde3d.f90 @@ -111,6 +111,7 @@ program spde3d character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing + integer :: csize ! aggregation size at which to stop. character(len=16) :: cmat ! coarse mat character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. @@ -200,6 +201,7 @@ program spde3d call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info) else nlv = 1 call mld_precinit(prec,prectype%prec, info, nlev=nlv) @@ -340,6 +342,7 @@ contains call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%athres,5) ! smoother aggr thresh + call read_data(prectype%csize,5) ! coarse size end if end if @@ -377,6 +380,7 @@ contains call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + call psb_bcast(ictxt,prectype%csize) ! coarse size end if if (iam == psb_root_) then From 7586e725ff604f1671346b1405c2393887441c0b Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 30 Apr 2012 15:12:52 +0000 Subject: [PATCH 11/11] mld2p4-NewNL: mlprec/mld_c_move_alloc_mod.f90 mlprec/mld_d_move_alloc_mod.f90 mlprec/mld_s_move_alloc_mod.f90 mlprec/mld_z_move_alloc_mod.f90 Fold move_alloc into onelev and prec_type. --- mlprec/mld_c_move_alloc_mod.f90 | 103 -------------------------------- mlprec/mld_d_move_alloc_mod.f90 | 103 -------------------------------- mlprec/mld_s_move_alloc_mod.f90 | 103 -------------------------------- mlprec/mld_z_move_alloc_mod.f90 | 103 -------------------------------- 4 files changed, 412 deletions(-) delete mode 100644 mlprec/mld_c_move_alloc_mod.f90 delete mode 100644 mlprec/mld_d_move_alloc_mod.f90 delete mode 100644 mlprec/mld_s_move_alloc_mod.f90 delete mode 100644 mlprec/mld_z_move_alloc_mod.f90 diff --git a/mlprec/mld_c_move_alloc_mod.f90 b/mlprec/mld_c_move_alloc_mod.f90 deleted file mode 100644 index d936c0fd..00000000 --- a/mlprec/mld_c_move_alloc_mod.f90 +++ /dev/null @@ -1,103 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,2010 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: mld_c_move_alloc_mod.f90 -! -! Module: mld_c_move_alloc_mod -! -! This module defines move_alloc-like routines, and related interfaces, -! for the preconditioner data structures. . -! - -module mld_c_move_alloc_mod - - use mld_c_prec_type - - interface mld_move_alloc - module procedure mld_c_onelev_prec_move_alloc,& - & mld_cprec_move_alloc - end interface - -contains - - subroutine mld_c_onelev_prec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_c_onelev_type), intent(inout) :: a, b - integer, intent(out) :: info - - call b%free(info) - b%parms = a%parms - call move_alloc(a%sm,b%sm) - if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) - b%base_a => a%base_a - b%base_desc => a%base_desc - - end subroutine mld_c_onelev_prec_move_alloc - - subroutine mld_cprec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_cprec_type), intent(inout) :: a - type(mld_cprec_type), intent(inout), target :: b - integer, intent(out) :: info - integer :: i - - if (allocated(b%precv)) then - ! This might not be required if FINAL procedures are available. - call mld_precfree(b,info) - if (info /= psb_success_) then - ! ????? - !!$ return - endif - end if - - call move_alloc(a%precv,b%precv) - ! Fix the pointers except on level 1. - do i=2, size(b%precv) - b%precv(i)%base_a => b%precv(i)%ac - b%precv(i)%base_desc => b%precv(i)%desc_ac - b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc - b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc - end do - end subroutine mld_cprec_move_alloc - - -end module mld_c_move_alloc_mod diff --git a/mlprec/mld_d_move_alloc_mod.f90 b/mlprec/mld_d_move_alloc_mod.f90 deleted file mode 100644 index 27f26fee..00000000 --- a/mlprec/mld_d_move_alloc_mod.f90 +++ /dev/null @@ -1,103 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,2010 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: mld_d_move_alloc_mod.f90 -! -! Module: mld_d_move_alloc_mod -! -! This module defines move_alloc-like routines, and related interfaces, -! for the preconditioner data structures. . -! - -module mld_d_move_alloc_mod - - use mld_d_prec_type - - interface mld_move_alloc - module procedure mld_d_onelev_prec_move_alloc,& - & mld_dprec_move_alloc - end interface - -contains - - subroutine mld_d_onelev_prec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_d_onelev_type), intent(inout) :: a, b - integer, intent(out) :: info - - call b%free(info) - b%parms = a%parms - call move_alloc(a%sm,b%sm) - if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) - b%base_a => a%base_a - b%base_desc => a%base_desc - - end subroutine mld_d_onelev_prec_move_alloc - - subroutine mld_dprec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_dprec_type), intent(inout) :: a - type(mld_dprec_type), intent(inout), target :: b - integer, intent(out) :: info - integer :: i - - if (allocated(b%precv)) then - ! This might not be required if FINAL procedures are available. - call mld_precfree(b,info) - if (info /= psb_success_) then - ! ????? - !!$ return - endif - end if - - call move_alloc(a%precv,b%precv) - ! Fix the pointers except on level 1. - do i=2, size(b%precv) - b%precv(i)%base_a => b%precv(i)%ac - b%precv(i)%base_desc => b%precv(i)%desc_ac - b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc - b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc - end do - end subroutine mld_dprec_move_alloc - - -end module mld_d_move_alloc_mod diff --git a/mlprec/mld_s_move_alloc_mod.f90 b/mlprec/mld_s_move_alloc_mod.f90 deleted file mode 100644 index 07676612..00000000 --- a/mlprec/mld_s_move_alloc_mod.f90 +++ /dev/null @@ -1,103 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,2010 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: mld_s_move_alloc_mod.f90 -! -! Module: mld_s_move_alloc_mod -! -! This module defines move_alloc-like routines, and related interfaces, -! for the preconditioner data structures. . -! - -module mld_s_move_alloc_mod - - use mld_s_prec_type - - interface mld_move_alloc - module procedure mld_s_onelev_prec_move_alloc,& - & mld_sprec_move_alloc - end interface - -contains - - subroutine mld_s_onelev_prec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_s_onelev_type), intent(inout) :: a, b - integer, intent(out) :: info - - call b%free(info) - b%parms = a%parms - call move_alloc(a%sm,b%sm) - if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) - b%base_a => a%base_a - b%base_desc => a%base_desc - - end subroutine mld_s_onelev_prec_move_alloc - - subroutine mld_sprec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_sprec_type), intent(inout) :: a - type(mld_sprec_type), intent(inout), target :: b - integer, intent(out) :: info - integer :: i - - if (allocated(b%precv)) then - ! This might not be required if FINAL procedures are available. - call mld_precfree(b,info) - if (info /= psb_success_) then - ! ????? - !!$ return - endif - end if - - call move_alloc(a%precv,b%precv) - ! Fix the pointers except on level 1. - do i=2, size(b%precv) - b%precv(i)%base_a => b%precv(i)%ac - b%precv(i)%base_desc => b%precv(i)%desc_ac - b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc - b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc - end do - end subroutine mld_sprec_move_alloc - - -end module mld_s_move_alloc_mod diff --git a/mlprec/mld_z_move_alloc_mod.f90 b/mlprec/mld_z_move_alloc_mod.f90 deleted file mode 100644 index 59be7ece..00000000 --- a/mlprec/mld_z_move_alloc_mod.f90 +++ /dev/null @@ -1,103 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,2010 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: mld_z_move_alloc_mod.f90 -! -! Module: mld_z_move_alloc_mod -! -! This module defines move_alloc-like routines, and related interfaces, -! for the preconditioner data structures. . -! - -module mld_z_move_alloc_mod - - use mld_z_prec_type - - interface mld_move_alloc - module procedure mld_z_onelev_prec_move_alloc,& - & mld_zprec_move_alloc - end interface - -contains - - subroutine mld_z_onelev_prec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_z_onelev_type), intent(inout) :: a, b - integer, intent(out) :: info - - call b%free(info) - b%parms = a%parms - call move_alloc(a%sm,b%sm) - if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) - b%base_a => a%base_a - b%base_desc => a%base_desc - - end subroutine mld_z_onelev_prec_move_alloc - - subroutine mld_zprec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_zprec_type), intent(inout) :: a - type(mld_zprec_type), intent(inout), target :: b - integer, intent(out) :: info - integer :: i - - if (allocated(b%precv)) then - ! This might not be required if FINAL procedures are available. - call mld_precfree(b,info) - if (info /= psb_success_) then - ! ????? - !!$ return - endif - end if - - call move_alloc(a%precv,b%precv) - ! Fix the pointers except on level 1. - do i=2, size(b%precv) - b%precv(i)%base_a => b%precv(i)%ac - b%precv(i)%base_desc => b%precv(i)%desc_ac - b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc - b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc - end do - end subroutine mld_zprec_move_alloc - - -end module mld_z_move_alloc_mod