From 26119298bd475ba37bf6b4425808354b06bcd9dd Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 9 Aug 2016 11:42:21 +0000 Subject: [PATCH 02/21] mld2p4-extaggr: mlprec/impl/mld_dcoarse_bld.f90 mlprec/mld_base_prec_type.F90 First steps towards external aggrgation. --- mlprec/impl/mld_dcoarse_bld.f90 | 62 +++++++++++++++++++++------------ mlprec/mld_base_prec_type.F90 | 15 ++++---- 2 files changed, 49 insertions(+), 28 deletions(-) diff --git a/mlprec/impl/mld_dcoarse_bld.f90 b/mlprec/impl/mld_dcoarse_bld.f90 index b52c4215..9cf4190e 100644 --- a/mlprec/impl/mld_dcoarse_bld.f90 +++ b/mlprec/impl/mld_dcoarse_bld.f90 @@ -112,40 +112,58 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info) call mld_check_def(p%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs) + select case(p%parms%aggr_alg) + case (mld_dec_aggr_, mld_sym_dec_aggr_) - ! - ! Build a mapping between the row indices of the fine-level matrix - ! and the row indices of the coarse-level matrix, according to a decoupled - ! aggregation algorithm. This also defines a tentative prolongator from - ! the coarse to the fine level. - ! - call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& - & a,desc_a,ilaggr,nlaggr,info) + ! + ! Build a mapping between the row indices of the fine-level matrix + ! and the row indices of the coarse-level matrix, according to a decoupled + ! aggregation algorithm. This also defines a tentative prolongator from + ! the coarse to the fine level. + ! + call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& + & a,desc_a,ilaggr,nlaggr,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') + goto 9999 + end if + + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by mld_aggrmap_bld and applying the aggregation + ! algorithm specified by p%iprcparm(mld_aggr_kind_) + ! + call mld_aggrmat_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_asb') + goto 9999 + end if - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') + case (mld_bcmatch_aggr_) + write(0,*) 'Matching is not implemented yet ' + info = -1111 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) goto 9999 - end if + + case default - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by mld_aggrmap_bld and applying the aggregation - ! algorithm specified by p%iprcparm(mld_aggr_kind_) - ! - call mld_aggrmat_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_asb') + info = -1 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) goto 9999 - end if + end select + ! ! Fix the base_a and base_desc pointers for handling of residuals. ! This is correct because this routine is only called at levels >=2. ! p%base_a => p%ac p%base_desc => p%desc_ac - + call psb_erractionrestore(err_act) return diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index d76806e1..04383e0b 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -257,10 +257,11 @@ module mld_base_prec_type ! integer(psb_ipk_), parameter :: mld_dec_aggr_ = 0 integer(psb_ipk_), parameter :: mld_sym_dec_aggr_ = 1 - integer(psb_ipk_), parameter :: mld_ext_aggr_ = 2 - integer(psb_ipk_), parameter :: mld_glb_aggr_ = 3 - integer(psb_ipk_), parameter :: mld_new_dec_aggr_ = 4 - integer(psb_ipk_), parameter :: mld_new_glb_aggr_ = 5 + integer(psb_ipk_), parameter :: mld_bcmatch_aggr_ = 2 + integer(psb_ipk_), parameter :: mld_ext_aggr_ = 3 + integer(psb_ipk_), parameter :: mld_glb_aggr_ = 4 + integer(psb_ipk_), parameter :: mld_new_dec_aggr_ = 5 + integer(psb_ipk_), parameter :: mld_new_glb_aggr_ = 6 integer(psb_ipk_), parameter :: mld_max_aggr_alg_ = mld_ext_aggr_ ! ! Legal values for entry: mld_aggr_ord_ @@ -335,8 +336,8 @@ module mld_base_prec_type character(len=15), parameter, private :: & & matrix_names(0:1)=(/'distributed ','replicated '/) character(len=18), parameter, private :: & - & aggr_names(0:5)=(/'local aggregation ','sym. local aggr. ',& - & 'user defined aggr.', 'global aggregation', & + & aggr_names(0:6)=(/'local aggregation ','sym. local aggr. ',& + & 'bootchmatch aggr. ','user defined aggr.', 'global aggregation', & & 'new local aggr. ','new global aggr. '/) character(len=18), parameter, private :: & & ord_names(0:1)=(/'Natural ordering ','Desc. degree ord. '/) @@ -450,6 +451,8 @@ contains val = mld_dec_aggr_ case('SYMDEC') val = mld_sym_dec_aggr_ + case('BCMATCH') + val = mld_bcmatch_aggr_ case('NAT','NATURAL') val = mld_aggr_ord_nat_ case('DESC','RDEGREE','DEGREE') From 37943c7b98727e98cb54460a24280d8ae61b12ea Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 9 Aug 2016 15:59:25 +0000 Subject: [PATCH 03/21] mld2p4-extaggr: mlprec/impl/mld_daggrmat_asb.f90 mlprec/impl/mld_dcoarse_bld.f90 mlprec/mld_d_inner_mod.f90 Refactoring steps: work split between coarse_bld and internals. --- mlprec/impl/mld_daggrmat_asb.f90 | 231 ++++++++++++++++--------------- mlprec/impl/mld_dcoarse_bld.f90 | 124 ++++++++++++++++- mlprec/mld_d_inner_mod.f90 | 26 ++-- 3 files changed, 249 insertions(+), 132 deletions(-) diff --git a/mlprec/impl/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 index 82613c50..69965097 100644 --- a/mlprec/impl/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -98,7 +98,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_daggrmat_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_asb @@ -109,11 +109,12 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms +!!$ type(mld_d_onelev_type), intent(inout), target :: p integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(inout) :: ac, op_prol,op_restr ! Local variables - 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(psb_ipk_) :: nzl,ntaggr, err_act @@ -133,26 +134,26 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_info(ictxt, me, np) - select case (p%parms%aggr_kind) + select case (parms%aggr_kind) case (mld_no_smooth_) call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & 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) + & parms,ac,op_prol,op_restr,info) case default info = psb_err_internal_error_ @@ -166,113 +167,113 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) end if - - ntaggr = sum(nlaggr) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call ac%mv_to(bcoo) - if (p%parms%clean_zeros) call bcoo%clean_zeros(info) - nzl = bcoo%get_nzeros() - - 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 - ! - ! Clip to local rows. - ! - call op_restr%set_nrows(p%desc_ac%get_local_rows()) - - 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 +!!$ +!!$ ntaggr = sum(nlaggr) +!!$ +!!$ select case(p%parms%coarse_mat) +!!$ +!!$ case(mld_distr_mat_) +!!$ +!!$ call ac%mv_to(bcoo) +!!$ if (p%parms%clean_zeros) call bcoo%clean_zeros(info) +!!$ nzl = bcoo%get_nzeros() +!!$ +!!$ 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 +!!$ ! +!!$ ! Clip to local rows. +!!$ ! +!!$ call op_restr%set_nrows(p%desc_ac%get_local_rows()) +!!$ +!!$ 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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) diff --git a/mlprec/impl/mld_dcoarse_bld.f90 b/mlprec/impl/mld_dcoarse_bld.f90 index 9cf4190e..11b368c6 100644 --- a/mlprec/impl/mld_dcoarse_bld.f90 +++ b/mlprec/impl/mld_dcoarse_bld.f90 @@ -83,11 +83,18 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info) integer(psb_mpik_) :: ictxt, np, me integer(psb_ipk_) :: err_act integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) + 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(psb_ipk_) :: nzl, ntaggr + integer(psb_ipk_) :: debug_level, debug_unit name='mld_dcoarse_bld' if (psb_get_errstatus().ne.0) return call psb_erractionsave(err_act) - info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ ictxt = desc_a%get_context() call psb_info(ictxt,me,np) @@ -114,7 +121,7 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info) select case(p%parms%aggr_alg) case (mld_dec_aggr_, mld_sym_dec_aggr_) - + ! ! Build a mapping between the row indices of the fine-level matrix ! and the row indices of the coarse-level matrix, according to a decoupled @@ -134,7 +141,7 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info) ! the mapping defined by mld_aggrmap_bld and applying the aggregation ! algorithm specified by p%iprcparm(mld_aggr_kind_) ! - call mld_aggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + call mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') @@ -156,7 +163,116 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info) goto 9999 end select - + + + ! Common code refactored here. + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + call ac%mv_to(bcoo) + if (p%parms%clean_zeros) call bcoo%clean_zeros(info) + nzl = bcoo%get_nzeros() + + 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 + ! + ! Clip to local rows. + ! + call op_restr%set_nrows(p%desc_ac%get_local_rows()) + + 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 ! ! Fix the base_a and base_desc pointers for handling of residuals. ! This is correct because this routine is only called at levels >=2. diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index bf891db2..3c50afd7 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -165,18 +165,18 @@ module mld_d_inner_mod 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_, psb_ipk_ - use mld_d_prec_type, only : mld_d_onelev_type - implicit none - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p - integer(psb_ipk_), intent(out) :: info - end subroutine mld_daggrmat_asb - end interface mld_aggrmat_asb +!!$ 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_, psb_ipk_ +!!$ use mld_d_prec_type, only : mld_d_onelev_type +!!$ implicit none +!!$ type(psb_dspmat_type), intent(in) :: a +!!$ type(psb_desc_type), intent(in) :: desc_a +!!$ integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) +!!$ type(mld_d_onelev_type), intent(inout), target :: p +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine mld_daggrmat_asb +!!$ end interface mld_aggrmat_asb @@ -197,7 +197,7 @@ module mld_d_inner_mod procedure(mld_daggrmat_var_asb) :: mld_daggrmat_nosmth_asb, & & mld_daggrmat_smth_asb, mld_daggrmat_minnrg_asb, & - & mld_daggrmat_biz_asb + & mld_daggrmat_biz_asb, mld_daggrmat_asb end module mld_d_inner_mod From 9f9ea6e7801826d6d8a0c274faea622273a1029f Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 16 Aug 2016 12:41:05 +0000 Subject: [PATCH 04/21] mld2p4-extaggr: mlprec/mld_base_prec_type.F90 --- mlprec/mld_base_prec_type.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 04383e0b..30b328b6 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -86,14 +86,14 @@ module mld_base_prec_type integer(psb_ipk_), parameter :: mld_patchlevel_ = 0 - type mld_aux_onelev_map_type - integer(psb_ipk_) :: naggr - integer(psb_ipk_), allocatable :: ilaggr(:) - end type mld_aux_onelev_map_type - - type mld_aux_map_type - type(mld_aux_onelev_map_type), allocatable :: mapv(:) - end type mld_aux_map_type +!!$ type mld_aux_onelev_map_type +!!$ integer(psb_ipk_) :: naggr +!!$ integer(psb_ipk_), allocatable :: ilaggr(:) +!!$ end type mld_aux_onelev_map_type +!!$ +!!$ type mld_aux_map_type +!!$ type(mld_aux_onelev_map_type), allocatable :: mapv(:) +!!$ end type mld_aux_map_type type mld_ml_parms integer(psb_ipk_) :: sweeps, sweeps_pre, sweeps_post From a20fb9ca0220170bfc7f5ee82ac1dcd4b44ae8cb Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 19 Aug 2016 15:33:01 +0000 Subject: [PATCH 05/21] *** empty log message *** --- mlprec/impl/mld_d_dec_map_bld.f90 | 459 ++++++++++++++++++++---------- 1 file changed, 311 insertions(+), 148 deletions(-) diff --git a/mlprec/impl/mld_d_dec_map_bld.f90 b/mlprec/impl/mld_d_dec_map_bld.f90 index 67e4437b..4d9b5876 100644 --- a/mlprec/impl/mld_d_dec_map_bld.f90 +++ b/mlprec/impl/mld_d_dec_map_bld.f90 @@ -56,10 +56,10 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& & ideg(:), idxs(:) real(psb_dpk_), allocatable :: val(:), diag(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip type(psb_d_csr_sparse_mat) :: acsr real(psb_dpk_) :: cpling, tcl - logical :: recovery + logical :: recovery, candidate integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -107,28 +107,28 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) call acsr%free() call psb_msort(ideg,ix=idxs,dir=psb_sort_down_) end if - ! Note: -(nr+1) Untouched as yet - ! -i 1<=i<=nr Adjacent to aggregate i - ! i 1<=i<=nr Belonging to aggregate i - ! - ! Phase one: group nodes together. - ! Very simple minded strategy. - ! - naggr = 0 - nlp = 0 - do + + + if (.true.) then + + ! + ! New version. + ! + + ! Note: -(nr+1) Untouched as yet + ! -i 1<=i<=nr Adjacent to aggregate i + ! i 1<=i<=nr Belonging to aggregate i + + + ! + ! Phase one: Start with disjoint groups. + ! + naggr = 0 icnt = 0 - do ii=1, nr + step1: do ii=1, nr i = idxs(ii) - if (ilaggr(i) == -(nr+1)) then - ! - ! 1. Untouched nodes are marked >0 together - ! with their neighbours - ! - icnt = icnt + 1 - naggr = naggr + 1 - ilaggr(i) = naggr + if (ilaggr(i) == -(nr+1)) then call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -136,175 +136,338 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if + ! + ! Build the set of all strongly coupled nodes + ! + ip = 0 do k=1, nz j = icol(k) if ((1<=j).and.(j<=nr)) then - ilg = ilaggr(j) - if ((ilg<0).and.(i /= j)) then - if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then - ilaggr(j) = naggr - else - ilaggr(j) = -naggr - endif + if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then + ip = ip + 1 + icol(ip) = icol(k) end if end if enddo + if (ip < 1) then + write(0,*) "Should at least contain the node itself ! " + cycle step1 + end if + candidate = .true. + do k=1, ip + candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) + end do + if (candidate) then + ! + ! If the whole strongly coupled neighborhood of I is + ! as yet unconnected, turn it into the next aggregate + ! + icnt = icnt + 1 + naggr = naggr + 1 + do k=1, ip + ilaggr(icol(k)) = naggr + end do + ilaggr(i) = naggr + end if + endif + enddo step1 + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & ' Check 1:',count(ilaggr == -(nr+1)) + end if + + ! + ! Phase two: join the neighbours + ! + step2: do ii=1,nr + i = idxs(ii) + + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getrow') + goto 9999 + end if ! - ! 2. Untouched neighbours of these nodes are marked <0. + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate ! - call a%get_neigh(i,neigh,n_ne,info,lev=2_psb_ipk_) + cpling = dzero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then + ip = k + cpling = abs(val(k)) + end if + end if + enddo + if (ip > 0) then + ilaggr(i) = ilaggr(icol(ip)) + end if + end if + end do step2 + + + ! + ! Phase three: sweep over leftovers, if any + ! + step3: do ii=1,nr + i = idxs(ii) + + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_neigh') + call psb_errpush(info,name,a_err='psb_sp_getrow') goto 9999 end if - - do n = 1, n_ne - m = neigh(n) - if ((1<=m).and.(m<=nr)) then - if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr - endif + ! + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate + ! + cpling = dzero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) < 0)) then + ip = ip + 1 + icol(ip) = icol(k) + end if + end if enddo - endif - enddo - nlp = nlp + 1 - if (icnt == 0) exit - enddo - if (debug_level >= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),& - & ' Check 1:',count(ilaggr == -(nr+1)) - end if + if (ip > 0) then + icnt = icnt + 1 + naggr = naggr + 1 + ilaggr(i) = naggr + do k=1, ip + ilaggr(icol(k)) = naggr + end do + else + ! + ! This should not happen: we did not even connect with ourselves. + ! Create an isolate anyway. + ! + naggr = naggr + 1 + ilaggr(i) = naggr + end if + end if + end do step3 + + + else + ! Original version, keep it for the time being + + ! Note: -(nr+1) Untouched as yet + ! -i 1<=i<=nr Adjacent to aggregate i + ! i 1<=i<=nr Belonging to aggregate i + ! + ! Phase one: group nodes together. + ! Very simple minded strategy. + ! + naggr = 0 + nlp = 0 + do + icnt = 0 + do ii=1, nr + i = idxs(ii) + if (ilaggr(i) == -(nr+1)) then + ! + ! 1. Untouched nodes are marked >0 together + ! with their neighbours + ! + icnt = icnt + 1 + naggr = naggr + 1 + ilaggr(i) = naggr + + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='csget') + goto 9999 + end if - ! - ! Phase two: sweep over leftovers. - ! - allocate(ils(nr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/naggr+10,izero,izero,izero,izero/),& - & a_err='integer') - goto 9999 - end if + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + ilg = ilaggr(j) + if ((ilg<0).and.(i /= j)) then + if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then + ilaggr(j) = naggr + else + ilaggr(j) = -naggr + endif + end if + end if + enddo + + ! + ! 2. Untouched neighbours of these nodes are marked <0. + ! + call a%get_neigh(i,neigh,n_ne,info,lev=2_psb_ipk_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_neigh') + goto 9999 + end if - do i=1, size(ils) - ils(i) = 0 - end do - do i=1, nr - n = ilaggr(i) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?') - goto 9999 - else - ils(n) = ils(n) + 1 - end if + do n = 1, n_ne + m = neigh(n) + if ((1<=m).and.(m<=nr)) then + if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr + endif + enddo + endif + enddo + nlp = nlp + 1 + if (icnt == 0) exit + enddo + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & ' Check 1:',count(ilaggr == -(nr+1)) + end if + ! + ! Phase two: sweep over leftovers. + ! + allocate(ils(nr),stat=info) + if(info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/naggr+10,izero,izero,izero,izero/),& + & a_err='integer') + goto 9999 end if - end do - if (debug_level >= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: number of aggregates ',naggr - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: nodes aggregated ',sum(ils) - end if - recovery=.false. - do i=1, nr - if (ilaggr(i) < 0) then - ! - ! Now some silly rule to break ties: - ! Group with adjacent aggregate. - ! - isz = nr+1 - ia = -1 - cpling = dzero - call a%csget(i,i,nz,irow,icol,val,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_getrow') - goto 9999 + do i=1, size(ils) + ils(i) = 0 + end do + do i=1, nr + n = ilaggr(i) + if (n>0) then + if (n>naggr) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?') + goto 9999 + else + ils(n) = ils(n) + 1 + end if + end if + end do + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 1: number of aggregates ',naggr + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 1: nodes aggregated ',sum(ils) + end if - do j=1, nz - k = icol(j) - if ((1<=k).and.(k<=nr).and.(k /= i)) then - tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k))) - if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then -!!$ if (tcl > theta) then - n = ilaggr(k) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') - goto 9999 - end if + recovery=.false. + do i=1, nr + if (ilaggr(i) < 0) then + ! + ! Now some silly rule to break ties: + ! Group with adjacent aggregate. + ! + isz = nr+1 + ia = -1 + cpling = dzero + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getrow') + goto 9999 + end if - if ((abs(val(j))>cpling) .or. & - & ((abs(val(j)) == cpling).and. (ils(n) < isz))) then + do j=1, nz + k = icol(j) + if ((1<=k).and.(k<=nr).and.(k /= i)) then + tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k))) + if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then +!!$ if (tcl > theta) then + n = ilaggr(k) + if (n>0) then + if (n>naggr) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') + goto 9999 + end if + + if ((abs(val(j))>cpling) .or. & + & ((abs(val(j)) == cpling).and. (ils(n) < isz))) then !!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then - ia = n - isz = ils(n) - cpling = abs(val(j)) + ia = n + isz = ils(n) + cpling = abs(val(j)) !!$ cpling = tcl + endif endif endif - endif - end if - enddo + end if + enddo - if (ia == -1) then - ! At this point, the easiest thing is to start a new aggregate - naggr = naggr + 1 - ilaggr(i) = naggr - ils(ilaggr(i)) = 1 + if (ia == -1) then + ! At this point, the easiest thing is to start a new aggregate + naggr = naggr + 1 + ilaggr(i) = naggr + ils(ilaggr(i)) = 1 - else + else - ilaggr(i) = ia + ilaggr(i) = ia - if (ia>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr ? ') - goto 9999 - end if - ils(ia) = ils(ia) + 1 - endif + if (ia>naggr) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr ? ') + goto 9999 + end if + ils(ia) = ils(ia) + 1 + endif - end if - end do - if (debug_level >= psb_debug_outer_) then - if (recovery) then + end if + end do + + if (debug_level >= psb_debug_outer_) then + if (recovery) then + write(debug_unit,*) me,' ',trim(name),& + & 'Had to recover from strange situation in loc_aggregate.' + write(debug_unit,*) me,' ',trim(name),& + & 'Perhaps an unsymmetric pattern?' + endif write(debug_unit,*) me,' ',trim(name),& - & 'Had to recover from strange situation in loc_aggregate.' + & 'Phase 2: number of aggregates ',naggr,sum(ils) + do i=1, naggr + write(debug_unit,*) me,' ',trim(name),& + & 'Size of aggregate ',i,' :',count(ilaggr == i), ils(i) + enddo write(debug_unit,*) me,' ',trim(name),& - & 'Perhaps an unsymmetric pattern?' - endif - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 2: number of aggregates ',naggr,sum(ils) - do i=1, naggr + & maxval(ils(1:naggr)) write(debug_unit,*) me,' ',trim(name),& - & 'Size of aggregate ',i,' :',count(ilaggr == i), ils(i) - enddo - write(debug_unit,*) me,' ',trim(name),& - & maxval(ils(1:naggr)) - write(debug_unit,*) me,' ',trim(name),& - & 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' + & 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' + end if + deallocate(ils,neigh,stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + end if + + if (count(ilaggr<0) >0) then info=psb_err_internal_error_ call psb_errpush(info,name,a_err='Fatal error: some leftovers') goto 9999 endif - deallocate(ils,neigh,stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if if (naggr > ncol) then write(0,*) name,'Error : naggr > ncol',naggr,ncol info=psb_err_internal_error_ From 5dc43358f76e5ec94163ebd6b261606bca289944 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 19 Aug 2016 15:47:16 +0000 Subject: [PATCH 06/21] mld2p4-extaggr: mlprec/impl/mld_c_dec_map_bld.f90 mlprec/impl/mld_d_dec_map_bld.f90 mlprec/impl/mld_s_dec_map_bld.f90 mlprec/impl/mld_z_dec_map_bld.f90 Reimplemented Vanek-Brezina decoupled aggregation. --- mlprec/impl/mld_c_dec_map_bld.f90 | 279 ++++++++---------- mlprec/impl/mld_d_dec_map_bld.f90 | 450 ++++++++---------------------- mlprec/impl/mld_s_dec_map_bld.f90 | 277 ++++++++---------- mlprec/impl/mld_z_dec_map_bld.f90 | 279 ++++++++---------- 4 files changed, 463 insertions(+), 822 deletions(-) diff --git a/mlprec/impl/mld_c_dec_map_bld.f90 b/mlprec/impl/mld_c_dec_map_bld.f90 index 7d0c5f94..35452b80 100644 --- a/mlprec/impl/mld_c_dec_map_bld.f90 +++ b/mlprec/impl/mld_c_dec_map_bld.f90 @@ -56,10 +56,10 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& & ideg(:), idxs(:) complex(psb_spk_), allocatable :: val(:), diag(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip type(psb_c_csr_sparse_mat) :: acsr real(psb_spk_) :: cpling, tcl - logical :: recovery + logical :: recovery, candidate integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -107,191 +107,148 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) call acsr%free() call psb_msort(ideg,ix=idxs,dir=psb_sort_down_) end if - ! Note: -(nr+1) Untouched as yet - ! -i 1<=i<=nr Adjacent to aggregate i - ! i 1<=i<=nr Belonging to aggregate i + + ! - ! Phase one: group nodes together. - ! Very simple minded strategy. + ! Phase one: Start with disjoint groups. ! naggr = 0 - nlp = 0 - do - icnt = 0 - do ii=1, nr - i = idxs(ii) - if (ilaggr(i) == -(nr+1)) then - ! - ! 1. Untouched nodes are marked >0 together - ! with their neighbours - ! - icnt = icnt + 1 - naggr = naggr + 1 - ilaggr(i) = naggr + icnt = 0 + step1: do ii=1, nr + i = idxs(ii) - call a%csget(i,i,nz,irow,icol,val,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='csget') - goto 9999 - end if + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='csget') + goto 9999 + end if - do k=1, nz - j = icol(k) - if ((1<=j).and.(j<=nr)) then - ilg = ilaggr(j) - if ((ilg<0).and.(i /= j)) then - if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then - ilaggr(j) = naggr - else - ilaggr(j) = -naggr - endif - end if + ! + ! Build the set of all strongly coupled nodes + ! + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then + ip = ip + 1 + icol(ip) = icol(k) end if - enddo + end if + enddo + if (ip < 1) then + write(0,*) "Should at least contain the node itself ! " + cycle step1 + end if + candidate = .true. + do k=1, ip + candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) + end do + if (candidate) then ! - ! 2. Untouched neighbours of these nodes are marked <0. + ! If the whole strongly coupled neighborhood of I is + ! as yet unconnected, turn it into the next aggregate ! - call a%get_neigh(i,neigh,n_ne,info,lev=2_psb_ipk_) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_neigh') - goto 9999 - end if - - do n = 1, n_ne - m = neigh(n) - if ((1<=m).and.(m<=nr)) then - if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr - endif - enddo - endif - enddo - nlp = nlp + 1 - if (icnt == 0) exit - enddo + icnt = icnt + 1 + naggr = naggr + 1 + do k=1, ip + ilaggr(icol(k)) = naggr + end do + ilaggr(i) = naggr + end if + endif + enddo step1 if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),& & ' Check 1:',count(ilaggr == -(nr+1)) end if ! - ! Phase two: sweep over leftovers. - ! - allocate(ils(nr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/naggr+10,izero,izero,izero,izero/),& - & a_err='integer') - goto 9999 - end if - - do i=1, size(ils) - ils(i) = 0 - end do - do i=1, nr - n = ilaggr(i) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?') - goto 9999 - else - ils(n) = ils(n) + 1 - end if - - end if - end do - if (debug_level >= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: number of aggregates ',naggr - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: nodes aggregated ',sum(ils) - end if + ! Phase two: join the neighbours + ! + step2: do ii=1,nr + i = idxs(ii) - recovery=.false. - do i=1, nr - if (ilaggr(i) < 0) then - ! - ! Now some silly rule to break ties: - ! Group with adjacent aggregate. - ! - isz = nr+1 - ia = -1 - cpling = czero + if (ilaggr(i) == -(nr+1)) then call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getrow') goto 9999 end if - - do j=1, nz - k = icol(j) - if ((1<=k).and.(k<=nr).and.(k /= i)) then - tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k))) - if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then -!!$ if (tcl > theta) then - n = ilaggr(k) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') - goto 9999 - end if - - if ((abs(val(j))>cpling) .or. & - & ((abs(val(j)) == cpling).and. (ils(n) < isz))) then -!!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then - ia = n - isz = ils(n) - cpling = abs(val(j)) -!!$ cpling = tcl - endif - endif - endif + ! + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate + ! + cpling = szero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then + ip = k + cpling = abs(val(k)) + end if end if enddo + if (ip > 0) then + ilaggr(i) = ilaggr(icol(ip)) + end if + end if + end do step2 - if (ia == -1) then - ! At this point, the easiest thing is to start a new aggregate - naggr = naggr + 1 - ilaggr(i) = naggr - ils(ilaggr(i)) = 1 - - else - ilaggr(i) = ia + ! + ! Phase three: sweep over leftovers, if any + ! + step3: do ii=1,nr + i = idxs(ii) - if (ia>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr ? ') - goto 9999 + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getrow') + goto 9999 + end if + ! + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate + ! + cpling = szero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) < 0)) then + ip = ip + 1 + icol(ip) = icol(k) + end if end if - ils(ia) = ils(ia) + 1 - endif - + enddo + if (ip > 0) then + icnt = icnt + 1 + naggr = naggr + 1 + ilaggr(i) = naggr + do k=1, ip + ilaggr(icol(k)) = naggr + end do + else + ! + ! This should not happen: we did not even connect with ourselves. + ! Create an isolate anyway. + ! + naggr = naggr + 1 + ilaggr(i) = naggr + end if end if - end do - if (debug_level >= psb_debug_outer_) then - if (recovery) then - write(debug_unit,*) me,' ',trim(name),& - & 'Had to recover from strange situation in loc_aggregate.' - write(debug_unit,*) me,' ',trim(name),& - & 'Perhaps an unsymmetric pattern?' - endif - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 2: number of aggregates ',naggr,sum(ils) - do i=1, naggr - write(debug_unit,*) me,' ',trim(name),& - & 'Size of aggregate ',i,' :',count(ilaggr == i), ils(i) - enddo - write(debug_unit,*) me,' ',trim(name),& - & maxval(ils(1:naggr)) - write(debug_unit,*) me,' ',trim(name),& - & 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' - end if + end do step3 + if (count(ilaggr<0) >0) then info=psb_err_internal_error_ @@ -299,12 +256,6 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 endif - deallocate(ils,neigh,stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if if (naggr > ncol) then write(0,*) name,'Error : naggr > ncol',naggr,ncol info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_d_dec_map_bld.f90 b/mlprec/impl/mld_d_dec_map_bld.f90 index 4d9b5876..fe263c2a 100644 --- a/mlprec/impl/mld_d_dec_map_bld.f90 +++ b/mlprec/impl/mld_d_dec_map_bld.f90 @@ -109,357 +109,145 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if - if (.true.) then - - ! - ! New version. - ! - - ! Note: -(nr+1) Untouched as yet - ! -i 1<=i<=nr Adjacent to aggregate i - ! i 1<=i<=nr Belonging to aggregate i - - - ! - ! Phase one: Start with disjoint groups. - ! - naggr = 0 - icnt = 0 - step1: do ii=1, nr - i = idxs(ii) + ! + ! Phase one: Start with disjoint groups. + ! + naggr = 0 + icnt = 0 + step1: do ii=1, nr + i = idxs(ii) + + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='csget') + goto 9999 + end if - if (ilaggr(i) == -(nr+1)) then - call a%csget(i,i,nz,irow,icol,val,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='csget') - goto 9999 + ! + ! Build the set of all strongly coupled nodes + ! + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then + ip = ip + 1 + icol(ip) = icol(k) + end if end if + enddo + if (ip < 1) then + write(0,*) "Should at least contain the node itself ! " + cycle step1 + end if + candidate = .true. + do k=1, ip + candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) + end do + if (candidate) then ! - ! Build the set of all strongly coupled nodes + ! If the whole strongly coupled neighborhood of I is + ! as yet unconnected, turn it into the next aggregate ! - ip = 0 - do k=1, nz - j = icol(k) - if ((1<=j).and.(j<=nr)) then - if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then - ip = ip + 1 - icol(ip) = icol(k) - end if - end if - enddo - if (ip < 1) then - write(0,*) "Should at least contain the node itself ! " - cycle step1 - end if - - candidate = .true. + icnt = icnt + 1 + naggr = naggr + 1 do k=1, ip - candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) + ilaggr(icol(k)) = naggr end do - if (candidate) then - ! - ! If the whole strongly coupled neighborhood of I is - ! as yet unconnected, turn it into the next aggregate - ! - icnt = icnt + 1 - naggr = naggr + 1 - do k=1, ip - ilaggr(icol(k)) = naggr - end do - ilaggr(i) = naggr - end if - endif - enddo step1 - if (debug_level >= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),& - & ' Check 1:',count(ilaggr == -(nr+1)) - end if - - ! - ! Phase two: join the neighbours - ! - step2: do ii=1,nr - i = idxs(ii) - - if (ilaggr(i) == -(nr+1)) then - call a%csget(i,i,nz,irow,icol,val,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_getrow') - goto 9999 - end if - ! - ! Find the most strongly connected neighbour that is - ! already aggregated, if any, and join its aggregate - ! - cpling = dzero - ip = 0 - do k=1, nz - j = icol(k) - if ((1<=j).and.(j<=nr)) then - if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& - & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then - ip = k - cpling = abs(val(k)) - end if - end if - enddo - if (ip > 0) then - ilaggr(i) = ilaggr(icol(ip)) - end if + ilaggr(i) = naggr end if - end do step2 + endif + enddo step1 + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & ' Check 1:',count(ilaggr == -(nr+1)) + end if - - ! - ! Phase three: sweep over leftovers, if any - ! - step3: do ii=1,nr - i = idxs(ii) - - if (ilaggr(i) == -(nr+1)) then - call a%csget(i,i,nz,irow,icol,val,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_getrow') - goto 9999 - end if - ! - ! Find the most strongly connected neighbour that is - ! already aggregated, if any, and join its aggregate - ! - cpling = dzero - ip = 0 - do k=1, nz - j = icol(k) - if ((1<=j).and.(j<=nr)) then - if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& - & .and. (ilaggr(j) < 0)) then - ip = ip + 1 - icol(ip) = icol(k) - end if - end if - enddo - if (ip > 0) then - icnt = icnt + 1 - naggr = naggr + 1 - ilaggr(i) = naggr - do k=1, ip - ilaggr(icol(k)) = naggr - end do - else - ! - ! This should not happen: we did not even connect with ourselves. - ! Create an isolate anyway. - ! - naggr = naggr + 1 - ilaggr(i) = naggr - end if + ! + ! Phase two: join the neighbours + ! + step2: do ii=1,nr + i = idxs(ii) + + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getrow') + goto 9999 end if - end do step3 - - - else - ! Original version, keep it for the time being - - ! Note: -(nr+1) Untouched as yet - ! -i 1<=i<=nr Adjacent to aggregate i - ! i 1<=i<=nr Belonging to aggregate i - ! - ! Phase one: group nodes together. - ! Very simple minded strategy. - ! - naggr = 0 - nlp = 0 - do - icnt = 0 - do ii=1, nr - i = idxs(ii) - if (ilaggr(i) == -(nr+1)) then - ! - ! 1. Untouched nodes are marked >0 together - ! with their neighbours - ! - icnt = icnt + 1 - naggr = naggr + 1 - ilaggr(i) = naggr - - call a%csget(i,i,nz,irow,icol,val,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='csget') - goto 9999 - end if - - do k=1, nz - j = icol(k) - if ((1<=j).and.(j<=nr)) then - ilg = ilaggr(j) - if ((ilg<0).and.(i /= j)) then - if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then - ilaggr(j) = naggr - else - ilaggr(j) = -naggr - endif - end if - end if - enddo - - ! - ! 2. Untouched neighbours of these nodes are marked <0. - ! - call a%get_neigh(i,neigh,n_ne,info,lev=2_psb_ipk_) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_neigh') - goto 9999 + ! + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate + ! + cpling = dzero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then + ip = k + cpling = abs(val(k)) end if - - do n = 1, n_ne - m = neigh(n) - if ((1<=m).and.(m<=nr)) then - if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr - endif - enddo - endif + end if enddo - nlp = nlp + 1 - if (icnt == 0) exit - enddo - if (debug_level >= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),& - & ' Check 1:',count(ilaggr == -(nr+1)) - end if - - ! - ! Phase two: sweep over leftovers. - ! - allocate(ils(nr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/naggr+10,izero,izero,izero,izero/),& - & a_err='integer') - goto 9999 + if (ip > 0) then + ilaggr(i) = ilaggr(icol(ip)) + end if end if + end do step2 - do i=1, size(ils) - ils(i) = 0 - end do - do i=1, nr - n = ilaggr(i) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?') - goto 9999 - else - ils(n) = ils(n) + 1 - end if + ! + ! Phase three: sweep over leftovers, if any + ! + step3: do ii=1,nr + i = idxs(ii) + + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getrow') + goto 9999 end if - end do - if (debug_level >= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: number of aggregates ',naggr - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: nodes aggregated ',sum(ils) - end if - - recovery=.false. - do i=1, nr - if (ilaggr(i) < 0) then + ! + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate + ! + cpling = dzero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) < 0)) then + ip = ip + 1 + icol(ip) = icol(k) + end if + end if + enddo + if (ip > 0) then + icnt = icnt + 1 + naggr = naggr + 1 + ilaggr(i) = naggr + do k=1, ip + ilaggr(icol(k)) = naggr + end do + else ! - ! Now some silly rule to break ties: - ! Group with adjacent aggregate. + ! This should not happen: we did not even connect with ourselves. + ! Create an isolate anyway. ! - isz = nr+1 - ia = -1 - cpling = dzero - call a%csget(i,i,nz,irow,icol,val,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_getrow') - goto 9999 - end if - - do j=1, nz - k = icol(j) - if ((1<=k).and.(k<=nr).and.(k /= i)) then - tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k))) - if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then -!!$ if (tcl > theta) then - n = ilaggr(k) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') - goto 9999 - end if - - if ((abs(val(j))>cpling) .or. & - & ((abs(val(j)) == cpling).and. (ils(n) < isz))) then -!!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then - ia = n - isz = ils(n) - cpling = abs(val(j)) -!!$ cpling = tcl - endif - endif - endif - end if - enddo - - if (ia == -1) then - ! At this point, the easiest thing is to start a new aggregate - naggr = naggr + 1 - ilaggr(i) = naggr - ils(ilaggr(i)) = 1 - - else - - ilaggr(i) = ia - - if (ia>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr ? ') - goto 9999 - end if - ils(ia) = ils(ia) + 1 - endif - + naggr = naggr + 1 + ilaggr(i) = naggr end if - end do - - if (debug_level >= psb_debug_outer_) then - if (recovery) then - write(debug_unit,*) me,' ',trim(name),& - & 'Had to recover from strange situation in loc_aggregate.' - write(debug_unit,*) me,' ',trim(name),& - & 'Perhaps an unsymmetric pattern?' - endif - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 2: number of aggregates ',naggr,sum(ils) - do i=1, naggr - write(debug_unit,*) me,' ',trim(name),& - & 'Size of aggregate ',i,' :',count(ilaggr == i), ils(i) - enddo - write(debug_unit,*) me,' ',trim(name),& - & maxval(ils(1:naggr)) - write(debug_unit,*) me,' ',trim(name),& - & 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' - end if - deallocate(ils,neigh,stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 end if - - - end if - + end do step3 if (count(ilaggr<0) >0) then diff --git a/mlprec/impl/mld_s_dec_map_bld.f90 b/mlprec/impl/mld_s_dec_map_bld.f90 index e980ecf8..10be26e0 100644 --- a/mlprec/impl/mld_s_dec_map_bld.f90 +++ b/mlprec/impl/mld_s_dec_map_bld.f90 @@ -56,10 +56,10 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& & ideg(:), idxs(:) real(psb_spk_), allocatable :: val(:), diag(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip type(psb_s_csr_sparse_mat) :: acsr real(psb_spk_) :: cpling, tcl - logical :: recovery + logical :: recovery, candidate integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -107,191 +107,148 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) call acsr%free() call psb_msort(ideg,ix=idxs,dir=psb_sort_down_) end if - ! Note: -(nr+1) Untouched as yet - ! -i 1<=i<=nr Adjacent to aggregate i - ! i 1<=i<=nr Belonging to aggregate i + + ! - ! Phase one: group nodes together. - ! Very simple minded strategy. + ! Phase one: Start with disjoint groups. ! naggr = 0 - nlp = 0 - do - icnt = 0 - do ii=1, nr - i = idxs(ii) - if (ilaggr(i) == -(nr+1)) then - ! - ! 1. Untouched nodes are marked >0 together - ! with their neighbours - ! - icnt = icnt + 1 - naggr = naggr + 1 - ilaggr(i) = naggr + icnt = 0 + step1: do ii=1, nr + i = idxs(ii) - call a%csget(i,i,nz,irow,icol,val,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='csget') - goto 9999 - end if + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='csget') + goto 9999 + end if - do k=1, nz - j = icol(k) - if ((1<=j).and.(j<=nr)) then - ilg = ilaggr(j) - if ((ilg<0).and.(i /= j)) then - if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then - ilaggr(j) = naggr - else - ilaggr(j) = -naggr - endif - end if + ! + ! Build the set of all strongly coupled nodes + ! + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then + ip = ip + 1 + icol(ip) = icol(k) end if - enddo + end if + enddo + if (ip < 1) then + write(0,*) "Should at least contain the node itself ! " + cycle step1 + end if + candidate = .true. + do k=1, ip + candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) + end do + if (candidate) then ! - ! 2. Untouched neighbours of these nodes are marked <0. + ! If the whole strongly coupled neighborhood of I is + ! as yet unconnected, turn it into the next aggregate ! - call a%get_neigh(i,neigh,n_ne,info,lev=2_psb_ipk_) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_neigh') - goto 9999 - end if - - do n = 1, n_ne - m = neigh(n) - if ((1<=m).and.(m<=nr)) then - if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr - endif - enddo - endif - enddo - nlp = nlp + 1 - if (icnt == 0) exit - enddo + icnt = icnt + 1 + naggr = naggr + 1 + do k=1, ip + ilaggr(icol(k)) = naggr + end do + ilaggr(i) = naggr + end if + endif + enddo step1 if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),& & ' Check 1:',count(ilaggr == -(nr+1)) end if ! - ! Phase two: sweep over leftovers. - ! - allocate(ils(nr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/naggr+10,izero,izero,izero,izero/),& - & a_err='integer') - goto 9999 - end if + ! Phase two: join the neighbours + ! + step2: do ii=1,nr + i = idxs(ii) - do i=1, size(ils) - ils(i) = 0 - end do - do i=1, nr - n = ilaggr(i) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?') - goto 9999 - else - ils(n) = ils(n) + 1 + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getrow') + goto 9999 end if - - end if - end do - if (debug_level >= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: number of aggregates ',naggr - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: nodes aggregated ',sum(ils) - end if - - recovery=.false. - do i=1, nr - if (ilaggr(i) < 0) then ! - ! Now some silly rule to break ties: - ! Group with adjacent aggregate. + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate ! - isz = nr+1 - ia = -1 cpling = szero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then + ip = k + cpling = abs(val(k)) + end if + end if + enddo + if (ip > 0) then + ilaggr(i) = ilaggr(icol(ip)) + end if + end if + end do step2 + + + ! + ! Phase three: sweep over leftovers, if any + ! + step3: do ii=1,nr + i = idxs(ii) + + if (ilaggr(i) == -(nr+1)) then call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getrow') goto 9999 end if - - do j=1, nz - k = icol(j) - if ((1<=k).and.(k<=nr).and.(k /= i)) then - tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k))) - if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then -!!$ if (tcl > theta) then - n = ilaggr(k) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') - goto 9999 - end if - - if ((abs(val(j))>cpling) .or. & - & ((abs(val(j)) == cpling).and. (ils(n) < isz))) then -!!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then - ia = n - isz = ils(n) - cpling = abs(val(j)) -!!$ cpling = tcl - endif - endif - endif + ! + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate + ! + cpling = szero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) < 0)) then + ip = ip + 1 + icol(ip) = icol(k) + end if end if enddo - - if (ia == -1) then - ! At this point, the easiest thing is to start a new aggregate - naggr = naggr + 1 - ilaggr(i) = naggr - ils(ilaggr(i)) = 1 - + if (ip > 0) then + icnt = icnt + 1 + naggr = naggr + 1 + ilaggr(i) = naggr + do k=1, ip + ilaggr(icol(k)) = naggr + end do else - - ilaggr(i) = ia - - if (ia>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr ? ') - goto 9999 - end if - ils(ia) = ils(ia) + 1 - endif - + ! + ! This should not happen: we did not even connect with ourselves. + ! Create an isolate anyway. + ! + naggr = naggr + 1 + ilaggr(i) = naggr + end if end if - end do - if (debug_level >= psb_debug_outer_) then - if (recovery) then - write(debug_unit,*) me,' ',trim(name),& - & 'Had to recover from strange situation in loc_aggregate.' - write(debug_unit,*) me,' ',trim(name),& - & 'Perhaps an unsymmetric pattern?' - endif - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 2: number of aggregates ',naggr,sum(ils) - do i=1, naggr - write(debug_unit,*) me,' ',trim(name),& - & 'Size of aggregate ',i,' :',count(ilaggr == i), ils(i) - enddo - write(debug_unit,*) me,' ',trim(name),& - & maxval(ils(1:naggr)) - write(debug_unit,*) me,' ',trim(name),& - & 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' - end if + end do step3 + if (count(ilaggr<0) >0) then info=psb_err_internal_error_ @@ -299,12 +256,6 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 endif - deallocate(ils,neigh,stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if if (naggr > ncol) then write(0,*) name,'Error : naggr > ncol',naggr,ncol info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_z_dec_map_bld.f90 b/mlprec/impl/mld_z_dec_map_bld.f90 index 718856aa..876b8a7e 100644 --- a/mlprec/impl/mld_z_dec_map_bld.f90 +++ b/mlprec/impl/mld_z_dec_map_bld.f90 @@ -56,10 +56,10 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& & ideg(:), idxs(:) complex(psb_dpk_), allocatable :: val(:), diag(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip type(psb_z_csr_sparse_mat) :: acsr real(psb_dpk_) :: cpling, tcl - logical :: recovery + logical :: recovery, candidate integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -107,191 +107,148 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) call acsr%free() call psb_msort(ideg,ix=idxs,dir=psb_sort_down_) end if - ! Note: -(nr+1) Untouched as yet - ! -i 1<=i<=nr Adjacent to aggregate i - ! i 1<=i<=nr Belonging to aggregate i + + ! - ! Phase one: group nodes together. - ! Very simple minded strategy. + ! Phase one: Start with disjoint groups. ! naggr = 0 - nlp = 0 - do - icnt = 0 - do ii=1, nr - i = idxs(ii) - if (ilaggr(i) == -(nr+1)) then - ! - ! 1. Untouched nodes are marked >0 together - ! with their neighbours - ! - icnt = icnt + 1 - naggr = naggr + 1 - ilaggr(i) = naggr + icnt = 0 + step1: do ii=1, nr + i = idxs(ii) - call a%csget(i,i,nz,irow,icol,val,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='csget') - goto 9999 - end if + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='csget') + goto 9999 + end if - do k=1, nz - j = icol(k) - if ((1<=j).and.(j<=nr)) then - ilg = ilaggr(j) - if ((ilg<0).and.(i /= j)) then - if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then - ilaggr(j) = naggr - else - ilaggr(j) = -naggr - endif - end if + ! + ! Build the set of all strongly coupled nodes + ! + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then + ip = ip + 1 + icol(ip) = icol(k) end if - enddo + end if + enddo + if (ip < 1) then + write(0,*) "Should at least contain the node itself ! " + cycle step1 + end if + candidate = .true. + do k=1, ip + candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) + end do + if (candidate) then ! - ! 2. Untouched neighbours of these nodes are marked <0. + ! If the whole strongly coupled neighborhood of I is + ! as yet unconnected, turn it into the next aggregate ! - call a%get_neigh(i,neigh,n_ne,info,lev=2_psb_ipk_) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_neigh') - goto 9999 - end if - - do n = 1, n_ne - m = neigh(n) - if ((1<=m).and.(m<=nr)) then - if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr - endif - enddo - endif - enddo - nlp = nlp + 1 - if (icnt == 0) exit - enddo + icnt = icnt + 1 + naggr = naggr + 1 + do k=1, ip + ilaggr(icol(k)) = naggr + end do + ilaggr(i) = naggr + end if + endif + enddo step1 if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),& & ' Check 1:',count(ilaggr == -(nr+1)) end if ! - ! Phase two: sweep over leftovers. - ! - allocate(ils(nr),stat=info) - if(info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/naggr+10,izero,izero,izero,izero/),& - & a_err='integer') - goto 9999 - end if - - do i=1, size(ils) - ils(i) = 0 - end do - do i=1, nr - n = ilaggr(i) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?') - goto 9999 - else - ils(n) = ils(n) + 1 - end if - - end if - end do - if (debug_level >= psb_debug_outer_) then - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: number of aggregates ',naggr - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 1: nodes aggregated ',sum(ils) - end if + ! Phase two: join the neighbours + ! + step2: do ii=1,nr + i = idxs(ii) - recovery=.false. - do i=1, nr - if (ilaggr(i) < 0) then - ! - ! Now some silly rule to break ties: - ! Group with adjacent aggregate. - ! - isz = nr+1 - ia = -1 - cpling = zzero + if (ilaggr(i) == -(nr+1)) then call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getrow') goto 9999 end if - - do j=1, nz - k = icol(j) - if ((1<=k).and.(k<=nr).and.(k /= i)) then - tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k))) - if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then -!!$ if (tcl > theta) then - n = ilaggr(k) - if (n>0) then - if (n>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') - goto 9999 - end if - - if ((abs(val(j))>cpling) .or. & - & ((abs(val(j)) == cpling).and. (ils(n) < isz))) then -!!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then - ia = n - isz = ils(n) - cpling = abs(val(j)) -!!$ cpling = tcl - endif - endif - endif + ! + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate + ! + cpling = dzero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then + ip = k + cpling = abs(val(k)) + end if end if enddo + if (ip > 0) then + ilaggr(i) = ilaggr(icol(ip)) + end if + end if + end do step2 - if (ia == -1) then - ! At this point, the easiest thing is to start a new aggregate - naggr = naggr + 1 - ilaggr(i) = naggr - ils(ilaggr(i)) = 1 - - else - ilaggr(i) = ia + ! + ! Phase three: sweep over leftovers, if any + ! + step3: do ii=1,nr + i = idxs(ii) - if (ia>naggr) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr ? ') - goto 9999 + if (ilaggr(i) == -(nr+1)) then + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getrow') + goto 9999 + end if + ! + ! Find the most strongly connected neighbour that is + ! already aggregated, if any, and join its aggregate + ! + cpling = dzero + ip = 0 + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (ilaggr(j) < 0)) then + ip = ip + 1 + icol(ip) = icol(k) + end if end if - ils(ia) = ils(ia) + 1 - endif - + enddo + if (ip > 0) then + icnt = icnt + 1 + naggr = naggr + 1 + ilaggr(i) = naggr + do k=1, ip + ilaggr(icol(k)) = naggr + end do + else + ! + ! This should not happen: we did not even connect with ourselves. + ! Create an isolate anyway. + ! + naggr = naggr + 1 + ilaggr(i) = naggr + end if end if - end do - if (debug_level >= psb_debug_outer_) then - if (recovery) then - write(debug_unit,*) me,' ',trim(name),& - & 'Had to recover from strange situation in loc_aggregate.' - write(debug_unit,*) me,' ',trim(name),& - & 'Perhaps an unsymmetric pattern?' - endif - write(debug_unit,*) me,' ',trim(name),& - & 'Phase 2: number of aggregates ',naggr,sum(ils) - do i=1, naggr - write(debug_unit,*) me,' ',trim(name),& - & 'Size of aggregate ',i,' :',count(ilaggr == i), ils(i) - enddo - write(debug_unit,*) me,' ',trim(name),& - & maxval(ils(1:naggr)) - write(debug_unit,*) me,' ',trim(name),& - & 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' - end if + end do step3 + if (count(ilaggr<0) >0) then info=psb_err_internal_error_ @@ -299,12 +256,6 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 endif - deallocate(ils,neigh,stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if if (naggr > ncol) then write(0,*) name,'Error : naggr > ncol',naggr,ncol info=psb_err_internal_error_ From 9bc34b0ae2d08d55a6f33e69b4df285b37ed04ae Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 23 Sep 2016 08:52:57 +0000 Subject: [PATCH 07/21] *** empty log message *** --- configure.ac | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index c927a31a..17187e65 100755 --- a/configure.ac +++ b/configure.ac @@ -107,7 +107,11 @@ case $docsdir in \/* ) eval "INSTALL_DOCSDIR=$docsdir";; * ) eval "INSTALL_DOCSDIR=$INSTALL_DIR/docs";; esac -AC_MSG_RESULT([$INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR]) +case $samplesdir in + \/* ) eval "INSTALL_SAMPLESDIR=$samplesdir";; + * ) eval "INSTALL_SAMPLESDIR=$INSTALL_DIR/samples";; +esac +AC_MSG_RESULT([$INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR $INSTALL_SAMPLESDIR]) ############################################################################### # Compilers detection: FC,F77,CC should be set, if found. @@ -282,6 +286,7 @@ AC_SUBST(INSTALL_DIR) AC_SUBST(INSTALL_LIBDIR) AC_SUBST(INSTALL_INCLUDEDIR) AC_SUBST(INSTALL_DOCSDIR) +AC_SUBST(INSTALL_SAMPLESDIR) AC_SUBST(EXTRA_LIBS) AC_SUBST(MUMPS_FLAGS) From 2eb10c08b728a891a242c114c424102123a4174a Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 23 Sep 2016 08:53:57 +0000 Subject: [PATCH 08/21] *** empty log message *** --- configure | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/configure b/configure index 9635281e..62b3e97c 100755 --- a/configure +++ b/configure @@ -649,6 +649,7 @@ SLU_FLAGS MUMPS_LIBS MUMPS_FLAGS EXTRA_LIBS +INSTALL_SAMPLESDIR INSTALL_DOCSDIR INSTALL_INCLUDEDIR INSTALL_LIBDIR @@ -2138,8 +2139,12 @@ case $docsdir in \/* ) eval "INSTALL_DOCSDIR=$docsdir";; * ) eval "INSTALL_DOCSDIR=$INSTALL_DIR/docs";; esac -{ $as_echo "$as_me:$LINENO: result: $INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR" >&5 -$as_echo "$INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR" >&6; } +case $samplesdir in + \/* ) eval "INSTALL_SAMPLESDIR=$samplesdir";; + * ) eval "INSTALL_SAMPLESDIR=$INSTALL_DIR/samples";; +esac +{ $as_echo "$as_me:$LINENO: result: $INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR $INSTALL_SAMPLESDIR" >&5 +$as_echo "$INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR $INSTALL_SAMPLESDIR" >&6; } ############################################################################### # Compilers detection: FC,F77,CC should be set, if found. @@ -8021,6 +8026,7 @@ fi + ############################################################################### From ac521deb6b8b780c61874cf4569139d92d4fbf08 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 23 Sep 2016 15:17:42 +0000 Subject: [PATCH 09/21] --- mlprec/mld_d_base_aggregator.f90 | 117 +++++++++++++++++++++++++++++++ 1 file changed, 117 insertions(+) create mode 100644 mlprec/mld_d_base_aggregator.f90 diff --git a/mlprec/mld_d_base_aggregator.f90 b/mlprec/mld_d_base_aggregator.f90 new file mode 100644 index 00000000..83573fcb --- /dev/null +++ b/mlprec/mld_d_base_aggregator.f90 @@ -0,0 +1,117 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +! +module mld_d_base_aggregator_mod + + use mld_base_prec_type + use psb_base_mod, only : psb_dspmat_type, psb_d_vect_type, & + & psb_d_base_vect_type, psb_dlinmap_type, psb_dpk_, & + & psb_ipk_, psb_long_int_k_, psb_desc_type, psb_i_base_vect_type, & + & psb_erractionsave, psb_error_handler + ! + ! sm - class(mld_T_base_smoother_type), allocatable + ! The current level preconditioner (aka smoother). + ! parms - type(mld_RTml_parms) + ! The parameters defining the multilevel strategy. + ! ac - The local part of the current-level matrix, built by + ! coarsening the previous-level matrix. + ! desc_ac - type(psb_desc_type). + ! The communication descriptor associated to the matrix + ! stored in ac. + ! base_a - type(psb_Tspmat_type), pointer. + ! Pointer (really a pointer!) to the local part of the current + ! matrix (so we have a unified treatment of residuals). + ! We need this to avoid passing explicitly the current matrix + ! to the routine which applies the preconditioner. + ! base_desc - type(psb_desc_type), pointer. + ! Pointer to the communication descriptor associated to the + ! matrix pointed by base_a. + ! map - Stores the maps (restriction and prolongation) between the + ! vector spaces associated to the index spaces of the previous + ! and current levels. + ! + ! Methods: + ! Most methods follow the encapsulation hierarchy: they take whatever action + ! is appropriate for the current object, then call the corresponding method for + ! the contained object. + ! As an example: the descr() method prints out a description of the + ! level. It starts by invoking the descr() method of the parms object, + ! then calls the descr() method of the smoother object. + ! + ! descr - Prints a description of the object. + ! default - Set default values + ! dump - Dump to file object contents + ! set - Sets various parameters; when a request is unknown + ! it is passed to the smoother object for further processing. + ! check - Sanity checks. + ! sizeof - Total memory occupation in bytes + ! get_nzeros - Number of nonzeros + ! + ! + type mld_d_base_aggregator_type + type(mld_dml_parms) :: parms + contains + procedure, pass(ag) :: bld => mld_d_base_aggregation_build + end type mld_d_onelev_type + + + private :: d_base_onelev_default, d_base_onelev_sizeof, & + & d_base_onelev_nullify, d_base_onelev_get_nzeros, & + & d_base_onelev_clone, d_base_onelev_move_alloc + + + + interface + subroutine mld_d_base_aggregation_build(ag,info,amold,vmold,imold) + import :: psb_d_base_sparse_mat, psb_d_base_vect_type, & + & psb_i_base_vect_type, psb_dpk_, mld_d_onelev_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + implicit none + class(mld_d_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_d_base_aggregation_build + end interface + + +contains + +end module mld_d_base_aggregator_mod From e1c05d0e228383fcb140d91d1b6ad590816e23e1 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 30 Sep 2016 13:59:41 +0000 Subject: [PATCH 10/21] mld2p4-extaggr: Make.inc.in Makefile mlprec/impl/Makefile mlprec/impl/mld_d_bld_mlhier_array.f90 mlprec/impl/mld_d_dec_map_bld.f90 mlprec/impl/mld_d_hierarchy_bld.f90 mlprec/impl/mld_d_lev_aggrmap_bld.f90 mlprec/impl/mld_d_lev_aggrmat_asb.f90 mlprec/impl/mld_daggrmap_bld.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_dcoarse_bld.f90 mlprec/impl/mld_dprecinit.F90 mlprec/mld_base_prec_type.F90 mlprec/mld_d_inner_mod.f90 tests/pdegen/mld_d_pde3d.f90 tests/pdegen/runs/ppde.inp Refactored map bld/mat asb routines. Now there is no need to call coarse_bld twice. To be cleaned up yet. --- Make.inc.in | 1 + Makefile | 4 + mlprec/impl/Makefile | 2 +- mlprec/impl/mld_d_bld_mlhier_array.f90 | 54 ++-- mlprec/impl/mld_d_dec_map_bld.f90 | 53 ++-- mlprec/impl/mld_d_hierarchy_bld.f90 | 353 +++++++++++++++++++++++- mlprec/impl/mld_d_lev_aggrmap_bld.f90 | 148 ++++++++++ mlprec/impl/mld_d_lev_aggrmat_asb.f90 | 252 +++++++++++++++++ mlprec/impl/mld_daggrmap_bld.f90 | 31 ++- mlprec/impl/mld_daggrmat_asb.f90 | 110 -------- mlprec/impl/mld_daggrmat_biz_asb.f90 | 25 +- mlprec/impl/mld_daggrmat_minnrg_asb.f90 | 23 +- mlprec/impl/mld_daggrmat_nosmth_asb.f90 | 31 +-- mlprec/impl/mld_daggrmat_smth_asb.f90 | 21 +- mlprec/impl/mld_dcoarse_bld.f90 | 322 +++++++++++---------- mlprec/impl/mld_dprecinit.F90 | 2 +- mlprec/mld_base_prec_type.F90 | 17 +- mlprec/mld_d_inner_mod.f90 | 49 ++-- tests/pdegen/mld_d_pde3d.f90 | 19 +- tests/pdegen/runs/ppde.inp | 22 +- 20 files changed, 1104 insertions(+), 435 deletions(-) create mode 100644 mlprec/impl/mld_d_lev_aggrmap_bld.f90 create mode 100644 mlprec/impl/mld_d_lev_aggrmat_asb.f90 diff --git a/Make.inc.in b/Make.inc.in index f03d5958..a89030d5 100644 --- a/Make.inc.in +++ b/Make.inc.in @@ -15,6 +15,7 @@ INSTALL_DIR=@INSTALL_DIR@ INSTALL_LIBDIR=@INSTALL_LIBDIR@ INSTALL_INCLUDEDIR=@INSTALL_INCLUDEDIR@ INSTALL_DOCSDIR=@INSTALL_DOCSDIR@ +INSTALL_SAMPLESDIR=@INSTALL_SAMPLESDIR@ ########################################################## diff --git a/Makefile b/Makefile index 5e66f185..413bb307 100644 --- a/Makefile +++ b/Makefile @@ -29,6 +29,10 @@ install: all /bin/cp -fr docs/*pdf docs/html $(INSTALL_DOCSDIR)) (./mkdir.sh $(INSTALL_DOCSDIR) && \ $(INSTALL_DATA) README LICENSE $(INSTALL_DOCSDIR)) + (./mkdir.sh $(INSTALL_SAMPLESDIR) && ./mkdir.sh $(INSTALL_SAMPLESDIR)/simple &&\ + ./mkdir.sh $(INSTALL_SAMPLESDIR)/advanced && \ + (cd examples; /bin/cp -fr pdegen fileread $(INSTALL_SAMPLESDIR)/simple ) && \ + (cd tests; /bin/cp -fr pdegen fileread $(INSTALL_SAMPLESDIR)/advanced )) cleanlib: (cd lib; /bin/rm -f *.a *$(.mod) *$(.fh)) (cd include; /bin/rm -f *.a *$(.mod) *$(.fh)) diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index c9c0e713..3db4d32f 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -26,7 +26,7 @@ DINNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_d_bld_mlhier_aggsize.o mld mld_d_ml_prec_bld.o mld_d_hierarchy_bld.o \ mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \ mld_d_dec_map_bld.o mld_dmlprec_aply.o mld_daggrmat_asb.o \ - $(DMPFOBJS) mld_d_extprol_bld.o + $(DMPFOBJS) mld_d_extprol_bld.o mld_d_lev_aggrmap_bld.o mld_d_lev_aggrmat_asb.o SINNEROBJS= mld_scoarse_bld.o mld_smlprec_bld.o mld_s_bld_mlhier_aggsize.o mld_s_bld_mlhier_array.o \ mld_s_ml_prec_bld.o mld_s_hierarchy_bld.o \ diff --git a/mlprec/impl/mld_d_bld_mlhier_array.f90 b/mlprec/impl/mld_d_bld_mlhier_array.f90 index 3618de1b..bd0a0e77 100644 --- a/mlprec/impl/mld_d_bld_mlhier_array.f90 +++ b/mlprec/impl/mld_d_bld_mlhier_array.f90 @@ -37,23 +37,25 @@ !!$ !!$ -subroutine mld_d_bld_mlhier_array(nplevs,a,desc_a,precv,info) +subroutine mld_d_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_d_bld_mlhier_array use mld_d_prec_mod implicit none - integer(psb_ipk_), intent(inout) :: nplevs + integer(psb_ipk_), intent(inout) :: nplevs, casize + real(psb_dpk_) :: mnaggratio type(psb_dspmat_type),intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_d_onelev_type),intent(inout), allocatable, target :: precv(:) integer(psb_ipk_), intent(out) :: info ! Local integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv + integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv, iaggsize integer(psb_ipk_) :: ipv(mld_ifpsz_), val class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm type(mld_dml_parms) :: baseparms, medparms, coarseparms type(mld_d_onelev_type), allocatable :: tprecv(:) + real(psb_dpk_) :: sizeratio integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -178,27 +180,45 @@ subroutine mld_d_bld_mlhier_array(nplevs,a,desc_a,precv,info) & write(debug_unit,*) me,' ',trim(name),& & 'Return from ',i,' call to mlprcbld ',info - if (i>2) then + iaggsize = sum(precv(i)%map%naggr) + if (iaggsize <= casize) then + newsz = i + end if + + if (i>2) then + sizeratio = iaggsize + sizeratio = sum(precv(i-1)%map%naggr)/sizeratio + if (sizeratio < mnaggratio) then + if (sizeratio > 1) then + newsz = i + else + ! + ! We are not gaining + ! + newsz = newsz-1 + end if + end if + if (all(precv(i)%map%naggr == precv(i-1)%map%naggr)) then newsz=i-1 + 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 end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) exit array_build_loop end do array_build_loop 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(tprecv(newsz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& diff --git a/mlprec/impl/mld_d_dec_map_bld.f90 b/mlprec/impl/mld_d_dec_map_bld.f90 index fe263c2a..363aeec0 100644 --- a/mlprec/impl/mld_d_dec_map_bld.f90 +++ b/mlprec/impl/mld_d_dec_map_bld.f90 @@ -54,12 +54,12 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! Local variables integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& - & ideg(:), idxs(:) + & ideg(:), idxs(:), tmpaggr(:) real(psb_dpk_), allocatable :: val(:), diag(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip, nisolate,nthird type(psb_d_csr_sparse_mat) :: acsr real(psb_dpk_) :: cpling, tcl - logical :: recovery, candidate + logical :: recovery, disjoint integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -114,6 +114,7 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! naggr = 0 icnt = 0 + nisolate = 0 step1: do ii=1, nr i = idxs(ii) @@ -138,20 +139,20 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if end if enddo - if (ip < 1) then - write(0,*) "Should at least contain the node itself ! " - cycle step1 - end if - candidate = .true. - do k=1, ip - candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) - end do - if (candidate) then - ! - ! If the whole strongly coupled neighborhood of I is - ! as yet unconnected, turn it into the next aggregate - ! +!!$ if (ip <= 1) then +!!$ nisolate = nisolate + 1 +!!$ cycle step1 +!!$ end if + + ! + ! If the whole strongly coupled neighborhood of I is + ! as yet unconnected, turn it into the next aggregate. + ! Same if ip==0 (in which case, neighborhood only + ! contains I even if it does not look from matrix) + ! + disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) + if (disjoint) then icnt = icnt + 1 naggr = naggr + 1 do k=1, ip @@ -161,6 +162,7 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if endif enddo step1 + if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),& & ' Check 1:',count(ilaggr == -(nr+1)) @@ -168,7 +170,8 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! ! Phase two: join the neighbours - ! + ! + tmpaggr = ilaggr step2: do ii=1,nr i = idxs(ii) @@ -188,8 +191,9 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) do k=1, nz j = icol(k) if ((1<=j).and.(j<=nr)) then - if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& - & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then +!!$ if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& +!!$ & .and. (tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then + if ((tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then ip = k cpling = abs(val(k)) end if @@ -205,10 +209,12 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! ! Phase three: sweep over leftovers, if any ! + nthird = 0 step3: do ii=1,nr i = idxs(ii) - if (ilaggr(i) == -(nr+1)) then + if (ilaggr(i) < 0) then + nthird = nthird + 1 call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -216,8 +222,8 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if ! - ! Find the most strongly connected neighbour that is - ! already aggregated, if any, and join its aggregate + ! Find its strongly connected neighbourhood not + ! already aggregated, and make it into a new aggregate. ! cpling = dzero ip = 0 @@ -282,7 +288,8 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) nlaggr(:) = 0 nlaggr(me+1) = naggr call psb_sum(ictxt,nlaggr(1:np)) - + + !write(*,*) me,'Info from dec_map_bld: ',naggr,nisolate,nthird call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_d_hierarchy_bld.f90 b/mlprec/impl/mld_d_hierarchy_bld.f90 index c43238dd..7bf307bd 100644 --- a/mlprec/impl/mld_d_hierarchy_bld.f90 +++ b/mlprec/impl/mld_d_hierarchy_bld.f90 @@ -94,9 +94,13 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! Local Variables integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs - real(psb_dpk_) :: mnaggratio - integer(psb_ipk_) :: ipv(mld_ifpsz_), val + integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize + real(psb_dpk_) :: mnaggratio, sizeratio + class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_dml_parms) :: baseparms, medparms, coarseparms + integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) + type(psb_dspmat_type) :: op_prol + type(mld_d_onelev_type), allocatable :: tprecv(:) integer(psb_ipk_) :: int_err(5) character :: upd_ integer(psb_ipk_) :: debug_level, debug_unit @@ -191,10 +195,23 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) goto 9999 endif + ! + ! The strategy: + ! 1. The maximum number of levels should be already encoded in the + ! size of the array; + ! 2. If the user did not specify anything, then a default coarse size + ! is generated, and the number of levels is set to the maximum; + ! 3. If the number of levels has been specified, make sure it's capped + ! at the maximum; + ! 4. If the size of the array is different from target number of levels, + ! reallocate; + ! 5. Build the matrix hierarchy, stopping early if either the target + ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! threshold. + ! + + if (nplevs <= 0) then - ! - ! This should become the default strategy, we specify a target aggregation size. - ! if (casize <=0) then ! ! Default to the cubic root of the size at base level. @@ -204,15 +221,321 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) casize = max(casize,ione) casize = casize*40_psb_ipk_ end if - call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info) - else - ! - ! Oldstyle with fixed number of levels. - ! - nplevs = max(itwo,min(nplevs,mxplevs)) - call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info) + nplevs = mxplevs end if - + + nplevs = max(itwo,min(nplevs,mxplevs)) + + 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 + + ! + ! First set desired number of levels + ! + if (iszv /= nplevs) then + allocate(tprecv(nplevs),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + tprecv(1)%parms = baseparms + allocate(tprecv(1)%sm,source=base_sm,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=2,nplevs-1 + tprecv(i)%parms = medparms + allocate(tprecv(i)%sm,source=med_sm,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + end do + tprecv(nplevs)%parms = coarseparms + allocate(tprecv(nplevs)%sm,source=coarse_sm,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,iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + iszv = size(p%precv) + end if + + ! + ! Finest level first; remember to fix base_a and base_desc + ! + p%precv(1)%base_a => a + p%precv(1)%base_desc => desc_a + newsz = 0 + if (.false.) then + old_array_build_loop: do i=2, iszv + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + 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 + + iaggsize = sum(p%precv(i)%map%naggr) + if (iaggsize <= casize) then + newsz = i + end if + + if (i>2) then + sizeratio = iaggsize + sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio + if (sizeratio < mnaggratio) then + if (sizeratio > 1) then + newsz = i + else + ! + ! We are not gaining + ! + newsz = newsz-1 + end if + end if + + if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + 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 + end if + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) exit old_array_build_loop + end do old_array_build_loop + + if (newsz > 0) then + ! + ! We exited early from the build loop, need to fix + ! the size. + ! + allocate(tprecv(newsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=1,newsz-1 + call p%precv(i)%move_alloc(tprecv(i),info) + end do + call p%precv(iszv)%move_alloc(tprecv(newsz),info) + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + ! 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 + 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 + + else + + array_build_loop: do i=2, iszv + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + 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_aggrmap_bld(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Map build') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + + + ! + ! Check for early termination of aggregation loop. + ! + iaggsize = sum(nlaggr) + if (iaggsize <= casize) then + newsz = i + end if + + if (i>2) then + sizeratio = iaggsize + sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio + if (sizeratio < mnaggratio) then + if (sizeratio > 1) then + newsz = i + else + ! + ! We are not gaining + ! + newsz = newsz-1 + end if + end if + + if (all(nlaggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + 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 + end if + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) & + & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) + + if (info == psb_success_) call mld_aggrmat_asb(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Map build') + goto 9999 + endif + + if (newsz > 0) exit array_build_loop + end do array_build_loop + + if (newsz > 0) then + ! + ! We exited early from the build loop, need to fix + ! the size. + ! + allocate(tprecv(newsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=1,newsz + call p%precv(i)%move_alloc(tprecv(i),info) + end do + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + ! 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 + 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 + end if + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) @@ -220,7 +543,7 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) endif iszv = size(p%precv) - + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Exiting with',iszv,' levels' diff --git a/mlprec/impl/mld_d_lev_aggrmap_bld.f90 b/mlprec/impl/mld_d_lev_aggrmap_bld.f90 new file mode 100644 index 00000000..eec9a32c --- /dev/null +++ b/mlprec/impl/mld_d_lev_aggrmap_bld.f90 @@ -0,0 +1,148 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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_dcoarse_bld.f90 +! +! Subroutine: mld_dcoarse_bld +! Version: real +! +! This routine builds the matrix associated to the current level of the +! multilevel preconditioner from the matrix associated to the previous level, +! by using a smoothed aggregation technique (therefore, it also builds the +! prolongation and restriction operators mapping the current level to the +! previous one and vice versa). Then the routine builds the base preconditioner +! at the current level. +! The current level is regarded as the coarse one, while the previous as +! the fine one. This is in agreement with the fact that the routine is called, +! by mld_mlprec_bld, only on levels >=2. +! +! +! Arguments: +! a - type(psb_dspmat_type). +! The sparse matrix structure containing the local part of the +! fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_d_onelev_type), input/output. +! The 'one-level' data structure containing the local part +! of the base preconditioner to be built as well as +! information concerning the prolongator and its transpose. +! info - integer, output. +! Error code. +! +subroutine mld_d_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + + use psb_base_mod + use mld_d_inner_mod, mld_protect_name => mld_d_lev_aggrmap_bld + + implicit none + + ! Arguments + type(mld_d_onelev_type), intent(inout), target :: p + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_dspmat_type), intent(out) :: op_prol + integer(psb_ipk_), intent(out) :: info + + + ! Local variables + character(len=20) :: name + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nzl, ntaggr + integer(psb_ipk_) :: debug_level, debug_unit + + name='mld_d_lev_aggrmap_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ictxt = desc_a%get_context() + call psb_info(ictxt,me,np) + + call mld_check_def(p%parms%ml_type,'Multilevel type',& + & mld_mult_ml_,is_legal_ml_type) + call mld_check_def(p%parms%aggr_alg,'Aggregation',& + & mld_dec_aggr_,is_legal_ml_aggr_alg) + call mld_check_def(p%parms%aggr_ord,'Ordering',& + & mld_aggr_ord_nat_,is_legal_ml_aggr_ord) + call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs) + + select case(p%parms%aggr_alg) + case (mld_dec_aggr_, mld_sym_dec_aggr_) + + ! + ! Build a mapping between the row indices of the fine-level matrix + ! and the row indices of the coarse-level matrix, according to a decoupled + ! aggregation algorithm. This also defines a tentative prolongator from + ! the coarse to the fine level. + ! + call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& + & a,desc_a,ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') + goto 9999 + end if + + case (mld_bcmatch_aggr_) + write(0,*) 'Matching is not implemented yet ' + info = -1111 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) + goto 9999 + + case default + + info = -1 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) + goto 9999 + + end select + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_d_lev_aggrmap_bld diff --git a/mlprec/impl/mld_d_lev_aggrmat_asb.f90 b/mlprec/impl/mld_d_lev_aggrmat_asb.f90 new file mode 100644 index 00000000..ca47cc2e --- /dev/null +++ b/mlprec/impl/mld_d_lev_aggrmat_asb.f90 @@ -0,0 +1,252 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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_dcoarse_bld.f90 +! +! Subroutine: mld_dcoarse_bld +! Version: real +! +! This routine builds the matrix associated to the current level of the +! multilevel preconditioner from the matrix associated to the previous level, +! by using a smoothed aggregation technique (therefore, it also builds the +! prolongation and restriction operators mapping the current level to the +! previous one and vice versa). Then the routine builds the base preconditioner +! at the current level. +! The current level is regarded as the coarse one, while the previous as +! the fine one. This is in agreement with the fact that the routine is called, +! by mld_mlprec_bld, only on levels >=2. +! +! +! Arguments: +! a - type(psb_dspmat_type). +! The sparse matrix structure containing the local part of the +! fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_d_onelev_type), input/output. +! The 'one-level' data structure containing the local part +! of the base preconditioner to be built as well as +! information concerning the prolongator and its transpose. +! info - integer, output. +! Error code. +! +subroutine mld_d_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + + use psb_base_mod + use mld_d_inner_mod, mld_protect_name => mld_d_lev_aggrmat_asb + + implicit none + + ! Arguments + type(mld_d_onelev_type), intent(inout), target :: p + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:) + type(psb_dspmat_type), intent(inout) :: op_prol + integer(psb_ipk_), intent(out) :: info + + + ! Local variables + character(len=20) :: name + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + type(psb_dspmat_type) :: ac, op_restr + type(psb_d_coo_sparse_mat) :: acoo, bcoo + type(psb_d_csr_sparse_mat) :: acsr1 + integer(psb_ipk_) :: nzl, ntaggr + integer(psb_ipk_) :: debug_level, debug_unit + + name='mld_dcoarse_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ictxt = desc_a%get_context() + call psb_info(ictxt,me,np) + + call mld_check_def(p%parms%aggr_kind,'Smoother',& + & mld_smooth_prol_,is_legal_ml_aggr_kind) + call mld_check_def(p%parms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_legal_ml_coarse_mat) + call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',& + & mld_no_filter_mat_,is_legal_aggr_filter) + call mld_check_def(p%parms%smoother_pos,'smooth_pos',& + & mld_pre_smooth_,is_legal_ml_smooth_pos) + call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',& + & mld_eig_est_,is_legal_ml_aggr_omega_alg) + call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',& + & mld_max_norm_,is_legal_ml_aggr_eig) + call mld_check_def(p%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) + + + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by mld_aggrmap_bld and applying the aggregation + ! algorithm specified by p%iprcparm(mld_aggr_kind_) + ! + call mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') + goto 9999 + end if + + + ! Common code refactored here. + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + call ac%mv_to(bcoo) + if (p%parms%clean_zeros) call bcoo%clean_zeros(info) + nzl = bcoo%get_nzeros() + + 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 + ! + ! Clip to local rows. + ! + call op_restr%set_nrows(p%desc_ac%get_local_rows()) + + 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + p%base_a => p%ac + p%base_desc => p%desc_ac + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_d_lev_aggrmat_asb diff --git a/mlprec/impl/mld_daggrmap_bld.f90 b/mlprec/impl/mld_daggrmap_bld.f90 index c652983a..de053aa6 100644 --- a/mlprec/impl/mld_daggrmap_bld.f90 +++ b/mlprec/impl/mld_daggrmap_bld.f90 @@ -79,7 +79,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) +subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmap_bld @@ -92,14 +92,15 @@ subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) real(psb_dpk_), intent(in) :: theta type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a + type(psb_dspmat_type), intent(out) :: op_prol integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_), allocatable :: ils(:), neigh(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m,naggrm1, naggrp1, ntaggr type(psb_dspmat_type) :: atmp, atrans - logical :: recovery + type(psb_d_coo_sparse_mat) :: tmpcoo integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -151,6 +152,30 @@ subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) goto 9999 end if + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + 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 + + call tmpcoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + tmpcoo%val(i) = done + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_sorted() ! At this point this is in row-major + call op_prol%mv_from(tmpcoo) + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 index 69965097..dd8dd9e4 100644 --- a/mlprec/impl/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -166,116 +166,6 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf goto 9999 end if - -!!$ -!!$ ntaggr = sum(nlaggr) -!!$ -!!$ select case(p%parms%coarse_mat) -!!$ -!!$ case(mld_distr_mat_) -!!$ -!!$ call ac%mv_to(bcoo) -!!$ if (p%parms%clean_zeros) call bcoo%clean_zeros(info) -!!$ nzl = bcoo%get_nzeros() -!!$ -!!$ 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 -!!$ ! -!!$ ! Clip to local rows. -!!$ ! -!!$ call op_restr%set_nrows(p%desc_ac%get_local_rows()) -!!$ -!!$ 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 90f95927..9d8dfa79 100644 --- a/mlprec/impl/mld_daggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_daggrmat_biz_asb.f90 @@ -89,7 +89,8 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_dspmat_type), intent(inout) :: op_prol + type(psb_dspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -128,19 +129,8 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - naggrm1 = sum(nlaggr(1:me)) - naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (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. ! @@ -157,17 +147,10 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr end if ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,naggr,ncol) - do i=1,nrow - tmpcoo%val(i) = done - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(nrow) - call tmpcoo%set_dupl(psb_dupl_add_) - + call op_prol%mv_to(tmpcoo) call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + if (info /= psb_success_) goto 9999 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 09e7bad6..a08ab607 100644 --- a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 @@ -109,7 +109,8 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_dspmat_type), intent(inout) :: op_prol + type(psb_dspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -167,14 +168,6 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re filter_mat = (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. ! @@ -209,20 +202,10 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - tmpcoo%val(i) = done - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(ncol) - call tmpcoo%set_dupl(psb_dupl_add_) - call tmpcoo%set_asb() + call op_prol%mv_to(tmpcoo) call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') -!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') - if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_) if (info /= psb_success_) then diff --git a/mlprec/impl/mld_daggrmat_nosmth_asb.f90 b/mlprec/impl/mld_daggrmat_nosmth_asb.f90 index 9fbec777..d4788037 100644 --- a/mlprec/impl/mld_daggrmat_nosmth_asb.f90 +++ b/mlprec/impl/mld_daggrmat_nosmth_asb.f90 @@ -92,7 +92,8 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_dspmat_type), intent(inout) :: op_prol + type(psb_dspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -124,34 +125,12 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ntaggr = sum(nlaggr) naggrm1=sum(nlaggr(1:me)) - 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 - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,nrow - acoo%val(i) = done - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - - 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(acoo) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call op_prol%transp(op_restr) - + if (info /= psb_success_) goto 9999 + call op_prol%transp(op_restr) + call a%cp_to(ac_coo) nzt = ac_coo%get_nzeros() diff --git a/mlprec/impl/mld_daggrmat_smth_asb.f90 b/mlprec/impl/mld_daggrmat_smth_asb.f90 index db400747..46b34133 100644 --- a/mlprec/impl/mld_daggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_daggrmat_smth_asb.f90 @@ -104,7 +104,8 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_dspmat_type), intent(inout) :: op_prol + type(psb_dspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -147,13 +148,6 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest naggrp1 = sum(nlaggr(1:me+1)) filter_mat = (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. @@ -172,17 +166,10 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest end if ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - tmpcoo%val(i) = done - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(ncol) - call tmpcoo%set_dupl(psb_dupl_add_) - call tmpcoo%set_sorted() ! At this point this is in row-major + call op_prol%mv_to(tmpcoo) call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + if (info /= psb_success_) goto 9999 if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_dcoarse_bld.f90 b/mlprec/impl/mld_dcoarse_bld.f90 index 11b368c6..b439d393 100644 --- a/mlprec/impl/mld_dcoarse_bld.f90 +++ b/mlprec/impl/mld_dcoarse_bld.f90 @@ -98,187 +98,213 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info) ictxt = desc_a%get_context() call psb_info(ictxt,me,np) - call mld_check_def(p%parms%ml_type,'Multilevel type',& - & mld_mult_ml_,is_legal_ml_type) - call mld_check_def(p%parms%aggr_alg,'Aggregation',& - & mld_dec_aggr_,is_legal_ml_aggr_alg) - call mld_check_def(p%parms%aggr_ord,'Ordering',& - & mld_aggr_ord_nat_,is_legal_ml_aggr_ord) - call mld_check_def(p%parms%aggr_kind,'Smoother',& - & mld_smooth_prol_,is_legal_ml_aggr_kind) - call mld_check_def(p%parms%coarse_mat,'Coarse matrix',& - & mld_distr_mat_,is_legal_ml_coarse_mat) - call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',& - & mld_no_filter_mat_,is_legal_aggr_filter) - call mld_check_def(p%parms%smoother_pos,'smooth_pos',& - & mld_pre_smooth_,is_legal_ml_smooth_pos) - call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',& - & mld_eig_est_,is_legal_ml_aggr_omega_alg) - call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',& - & mld_max_norm_,is_legal_ml_aggr_eig) - call mld_check_def(p%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) - call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs) - - select case(p%parms%aggr_alg) - case (mld_dec_aggr_, mld_sym_dec_aggr_) - - ! - ! Build a mapping between the row indices of the fine-level matrix - ! and the row indices of the coarse-level matrix, according to a decoupled - ! aggregation algorithm. This also defines a tentative prolongator from - ! the coarse to the fine level. - ! - call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& - & a,desc_a,ilaggr,nlaggr,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') + + if (.true.) then + call mld_aggrmap_bld(p,& + & a,desc_a,ilaggr,nlaggr,op_prol,info) + else + call mld_check_def(p%parms%ml_type,'Multilevel type',& + & mld_mult_ml_,is_legal_ml_type) + call mld_check_def(p%parms%aggr_alg,'Aggregation',& + & mld_dec_aggr_,is_legal_ml_aggr_alg) + call mld_check_def(p%parms%aggr_ord,'Ordering',& + & mld_aggr_ord_nat_,is_legal_ml_aggr_ord) + call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs) + + select case(p%parms%aggr_alg) + case (mld_dec_aggr_, mld_sym_dec_aggr_) + + ! + ! Build a mapping between the row indices of the fine-level matrix + ! and the row indices of the coarse-level matrix, according to a decoupled + ! aggregation algorithm. This also defines a tentative prolongator from + ! the coarse to the fine level. + ! + call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& + & a,desc_a,ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') + goto 9999 + end if + + case (mld_bcmatch_aggr_) + write(0,*) 'Matching is not implemented yet ' + info = -1111 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) goto 9999 - end if - + + case default + + info = -1 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) + goto 9999 + + end select + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') + goto 9999 + end if + + + if (.true.) then + call mld_aggrmat_asb(p,& + & a,desc_a,ilaggr,nlaggr,op_prol,info) + else + + + call mld_check_def(p%parms%aggr_kind,'Smoother',& + & mld_smooth_prol_,is_legal_ml_aggr_kind) + call mld_check_def(p%parms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_legal_ml_coarse_mat) + call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',& + & mld_no_filter_mat_,is_legal_aggr_filter) + call mld_check_def(p%parms%smoother_pos,'smooth_pos',& + & mld_pre_smooth_,is_legal_ml_smooth_pos) + call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',& + & mld_eig_est_,is_legal_ml_aggr_omega_alg) + call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',& + & mld_max_norm_,is_legal_ml_aggr_eig) + call mld_check_def(p%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) + + ! ! Build the coarse-level matrix from the fine-level one, starting from ! the mapping defined by mld_aggrmap_bld and applying the aggregation ! algorithm specified by p%iprcparm(mld_aggr_kind_) ! call mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info) - + if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') goto 9999 end if - case (mld_bcmatch_aggr_) - write(0,*) 'Matching is not implemented yet ' - info = -1111 - call psb_errpush(psb_err_input_value_invalid_i_,name,& - & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) - goto 9999 - - case default - info = -1 - call psb_errpush(psb_err_input_value_invalid_i_,name,& - & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) - goto 9999 + ! Common code refactored here. - end select - + ntaggr = sum(nlaggr) - ! Common code refactored here. - - ntaggr = sum(nlaggr) + select case(p%parms%coarse_mat) - select case(p%parms%coarse_mat) + case(mld_distr_mat_) - case(mld_distr_mat_) - - call ac%mv_to(bcoo) - if (p%parms%clean_zeros) call bcoo%clean_zeros(info) - nzl = bcoo%get_nzeros() - - 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 ac%mv_to(bcoo) + if (p%parms%clean_zeros) call bcoo%clean_zeros(info) + nzl = bcoo%get_nzeros() - 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_) 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') - goto 9999 - end if + 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 (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') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') 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 + + 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 - end if - ! - ! Clip to local rows. - ! - call op_restr%set_nrows(p%desc_ac%get_local_rows()) + ! + ! Clip to local rows. + ! + call op_restr%set_nrows(p%desc_ac%get_local_rows()) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' + 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_).and.p%parms%clean_zeros) call ac%clean_zeros(info) - if (info == psb_success_) & - & call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 + if (info /= psb_success_) goto 9999 - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select + case 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 + 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 - ! + ! + ! 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 + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + p%base_a => p%ac + p%base_desc => p%desc_ac + end if - 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_from_subroutine_,name,a_err='mld_aggrmat_asb') goto 9999 end if - ! - ! Fix the base_a and base_desc pointers for handling of residuals. - ! This is correct because this routine is only called at levels >=2. - ! - p%base_a => p%ac - p%base_desc => p%desc_ac + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_dprecinit.F90 b/mlprec/impl/mld_dprecinit.F90 index 3276c9e7..c421d04d 100644 --- a/mlprec/impl/mld_dprecinit.F90 +++ b/mlprec/impl/mld_dprecinit.F90 @@ -171,7 +171,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev) nlev_ = max(1,nlev) p%n_prec_levs = nlev_ else - nlev_ = 3 + nlev_ = p%max_prec_levs p%n_prec_levs = -ione end if ilev_ = 1 diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 30b328b6..2effe9c6 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -103,11 +103,12 @@ module mld_base_prec_type integer(psb_ipk_) :: coarse_mat, coarse_solve logical :: clean_zeros=.true. contains - procedure, pass(pm) :: clone => ml_parms_clone - procedure, pass(pm) :: descr => ml_parms_descr - procedure, pass(pm) :: mldescr => ml_parms_mldescr + procedure, pass(pm) :: get_coarse => ml_parms_get_coarse + procedure, pass(pm) :: clone => ml_parms_clone + 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 + procedure, pass(pm) :: printout => ml_parms_printout end type mld_ml_parms @@ -506,6 +507,14 @@ contains end select end function mld_stringval + subroutine ml_parms_get_coarse(pm,pmin) + implicit none + class(mld_ml_parms), intent(inout) :: pm + class(mld_ml_parms), intent(in) :: pmin + pm%coarse_mat = pmin%coarse_mat + pm%coarse_solve = pmin%coarse_solve + end subroutine ml_parms_get_coarse + subroutine ml_parms_printout(pm,iout) diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index 3c50afd7..f8012673 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -124,11 +124,12 @@ module mld_d_inner_mod end interface mld_bld_mlhier_aggsize interface mld_bld_mlhier_array - subroutine mld_d_bld_mlhier_array(nplevs,a,desc_a,precv,info) - use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type + subroutine mld_d_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) + use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type, psb_dpk_ use mld_d_prec_type, only : mld_d_onelev_type implicit none - integer(psb_ipk_), intent(inout) :: nplevs + integer(psb_ipk_), intent(inout) :: nplevs, casize + real(psb_dpk_) :: mnaggratio type(psb_dspmat_type),intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_d_onelev_type), allocatable, target, intent(inout) :: precv(:) @@ -137,7 +138,18 @@ module mld_d_inner_mod end interface mld_bld_mlhier_array interface mld_aggrmap_bld - subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) + subroutine mld_d_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ + use mld_d_prec_type, only : mld_d_onelev_type + implicit none + type(mld_d_onelev_type), intent(inout), target :: p + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_dspmat_type), intent(out) :: op_prol + integer(psb_ipk_), intent(out) :: info + end subroutine mld_d_lev_aggrmap_bld + subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ implicit none integer(psb_ipk_), intent(in) :: iorder @@ -146,6 +158,7 @@ module mld_d_inner_mod type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_dspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_daggrmap_bld end interface mld_aggrmap_bld @@ -165,18 +178,19 @@ module mld_d_inner_mod 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_, psb_ipk_ -!!$ use mld_d_prec_type, only : mld_d_onelev_type -!!$ implicit none -!!$ type(psb_dspmat_type), intent(in) :: a -!!$ type(psb_desc_type), intent(in) :: desc_a -!!$ integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) -!!$ type(mld_d_onelev_type), intent(inout), target :: p -!!$ integer(psb_ipk_), intent(out) :: info -!!$ end subroutine mld_daggrmat_asb -!!$ end interface mld_aggrmat_asb + interface mld_aggrmat_asb + subroutine mld_d_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ + use mld_d_prec_type, only : mld_d_onelev_type + implicit none + type(mld_d_onelev_type), intent(inout), target :: p + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:) + type(psb_dspmat_type), intent(inout) :: op_prol + integer(psb_ipk_), intent(out) :: info + end subroutine mld_d_lev_aggrmat_asb + end interface mld_aggrmat_asb @@ -189,7 +203,8 @@ module mld_d_inner_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_dspmat_type), intent(inout) :: op_prol + type(psb_dspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info end subroutine mld_daggrmat_var_asb end interface diff --git a/tests/pdegen/mld_d_pde3d.f90 b/tests/pdegen/mld_d_pde3d.f90 index 07020a0c..d6a62892 100644 --- a/tests/pdegen/mld_d_pde3d.f90 +++ b/tests/pdegen/mld_d_pde3d.f90 @@ -186,6 +186,8 @@ program mld_d_pde3d type(precdata) :: prectype type(psb_d_coo_sparse_mat) :: acoo ! other variables + character(len=20) :: dump_prefix + logical :: dump_sol=.false., dump_prec=.false. integer(psb_ipk_) :: info, i character(len=20) :: name,ch_err @@ -214,7 +216,8 @@ program mld_d_pde3d ! ! get parameters ! - call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,& + &dump_prec,dump_prefix) ! ! allocate and fill in the coefficient matrix, rhs and initial guess @@ -380,6 +383,10 @@ program mld_d_pde3d write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize end if + if (dump_prec) call prec%dump(info,prefix=trim(dump_prefix),& + & ac=.true.,solver=.true.,smoother=.true.,rp=.true.,global_num=.true.) + + ! ! cleanup storage and exit ! @@ -404,13 +411,17 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,& + & dump_prec,dump_prefix) + integer(psb_ipk_) :: ictxt type(precdata) :: prectype character(len=*) :: kmethd, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst integer(psb_ipk_) :: np, iam, info real(psb_dpk_) :: eps + logical :: dump_prec + character(len=*) :: dump_prefix character(len=20) :: buffer call psb_info(ictxt, iam, np) @@ -424,6 +435,8 @@ contains call read_data(itrace,psb_inp_unit) call read_data(irst,psb_inp_unit) call read_data(eps,psb_inp_unit) + call read_data(dump_prec,psb_inp_unit) + call read_data(dump_prefix,psb_inp_unit) call read_data(prectype%descr,psb_inp_unit) ! verbose description of the prec call read_data(prectype%prec,psb_inp_unit) ! overall prectype call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels @@ -462,6 +475,8 @@ contains call psb_bcast(ictxt,itrace) call psb_bcast(ictxt,irst) call psb_bcast(ictxt,eps) + call psb_bcast(ictxt,dump_prec) + call psb_bcast(ictxt,dump_prefix) call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec call psb_bcast(ictxt,prectype%prec) ! overall prectype call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 66d7129d..f692ddef 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -6,30 +6,32 @@ CSR ! Storage format CSR COO JAD 10 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS +F ! Dump preconditioner on file T F +test-ml-unsm-our ! File prefix for preconditioner dump ML-MUL-RAS-ILU ! Descriptive name for preconditioner (up to 40 chars) ML ! Preconditioner NONE JACOBI BJAC AS ML --1 ! If ML: Prescribed number of levels; if <0, ignore it and use coarse size. --010 ! If ML: Target coarse size. If <0, then use library default +-4 ! If ML: Prescribed number of levels; if <0, ignore it and use coarse size. +-8000 ! If ML: Target coarse size. If <0, then use library default -1.5d0 ! If ML: Minimum aggregation ratio; if <0 use library default -0.10d0 ! If ML: Smoother Aggregation Threshold: >= 0.0 default if <0 -20 ! If ML: Maximum acceptable number of levels; if <0 use library default -SMOOTHED ! Type of aggregation: SMOOTHED, NONSMOOTHED, MINENERGY -SYMDEC ! Type of aggregation: DEC SYMDEC +SMOOTHED ! Type of aggregation: SMOOTHED, UNSMOOTHED, MINENERGY +DEC ! Type of aggregation: DEC SYMDEC NATURAL ! Ordering of aggregation: NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT KCYCLE VCYCLE WCYCLE KCYCLESYM TWOSIDE ! Side of correction: PRE POST TWOSIDE (ignored for ADD) -4 ! Smoother sweeps +2 ! Smoother sweeps BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML 0 ! Number of overlap layers for AS preconditioner (at finest level) HALO ! AS Restriction operator NONE HALO NONE ! AS Prolongation operator NONE SUM AVG -GS ! Subdomain solver DSCALE ILU MILU ILUT FWGS BWGS MUMPS UMF SLU -4 ! Solver sweeps for GS +FWGS ! Subdomain solver DSCALE ILU MILU ILUT FWGS BWGS MUMPS UMF SLU +1 ! Solver sweeps for GS 0 ! Level-set N for ILU(N), and P for ILUT 1.d-4 ! Threshold T for ILU(T,P) DIST ! Coarse level: matrix distribution DIST REPL BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST MUMPS -ILU ! Coarse level: subsolver DSCALE GS BWGS ILU UMF SLU SLUDIST MUMPS -1 ! Coarse level: Level-set N for ILU(N) +FWGS ! Coarse level: subsolver DSCALE GS BWGS ILU UMF SLU SLUDIST MUMPS +0 ! 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 +2 ! Coarse level: Number of Jacobi sweeps From c4ed193949fe036b9cb7e4733b540f50e42008c0 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 30 Sep 2016 16:23:47 +0000 Subject: [PATCH 11/21] mld2p4-extaggr: mlprec/mld_base_prec_type.F90 Make filter an allowed option. --- mlprec/mld_base_prec_type.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 2effe9c6..2fbdec20 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -252,7 +252,7 @@ module mld_base_prec_type ! integer(psb_ipk_), parameter :: mld_no_filter_mat_ = 0 integer(psb_ipk_), parameter :: mld_filter_mat_ = 1 - integer(psb_ipk_), parameter :: mld_max_filter_mat_ = mld_no_filter_mat_ + integer(psb_ipk_), parameter :: mld_max_filter_mat_ = mld_filter_mat_ ! ! Legal values for entry: mld_aggr_alg_ ! From 42b7a3770a2f89597e87537a8a997ab358dd1b15 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 30 Sep 2016 19:17:10 +0000 Subject: [PATCH 12/21] mld2p4-extaggr: mlprec/impl/mld_d_dec_map_bld.f90 mlprec/impl/mld_d_hierarchy_bld.f90 mlprec/mld_d_inner_mod.f90 tests/pdegen/mld_d_pde3d.f90 New organization of aggregation routines. --- mlprec/impl/mld_d_dec_map_bld.f90 | 6 +- mlprec/impl/mld_d_hierarchy_bld.f90 | 339 +++++++++------------------- mlprec/mld_d_inner_mod.f90 | 5 +- tests/pdegen/mld_d_pde3d.f90 | 1 + 4 files changed, 115 insertions(+), 236 deletions(-) diff --git a/mlprec/impl/mld_d_dec_map_bld.f90 b/mlprec/impl/mld_d_dec_map_bld.f90 index 363aeec0..c4128a19 100644 --- a/mlprec/impl/mld_d_dec_map_bld.f90 +++ b/mlprec/impl/mld_d_dec_map_bld.f90 @@ -191,9 +191,9 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) do k=1, nz j = icol(k) if ((1<=j).and.(j<=nr)) then -!!$ if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& -!!$ & .and. (tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then - if ((tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then + if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& + & .and. (tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then +!!$ if ((tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then ip = k cpling = abs(val(k)) end if diff --git a/mlprec/impl/mld_d_hierarchy_bld.f90 b/mlprec/impl/mld_d_hierarchy_bld.f90 index 7bf307bd..42a33e94 100644 --- a/mlprec/impl/mld_d_hierarchy_bld.f90 +++ b/mlprec/impl/mld_d_hierarchy_bld.f90 @@ -287,255 +287,134 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) p%precv(1)%base_a => a p%precv(1)%base_desc => desc_a newsz = 0 - if (.false.) then - old_array_build_loop: do i=2, iszv + array_build_loop: do i=2, iszv + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + 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_aggrmap_bld(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) - if (debug_level >= 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='Map build') + goto 9999 + endif - 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 (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info - iaggsize = sum(p%precv(i)%map%naggr) - if (iaggsize <= casize) then - newsz = i - end if + ! + ! Check for early termination of aggregation loop. + ! + iaggsize = sum(nlaggr) + if (iaggsize <= casize) then + newsz = i + end if - if (i>2) then - sizeratio = iaggsize - sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio - if (sizeratio < mnaggratio) then - if (sizeratio > 1) then - newsz = i - else - ! - ! We are not gaining - ! - newsz = newsz-1 - end if + if (i>2) then + sizeratio = iaggsize + sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio + if (sizeratio < mnaggratio) then + if (sizeratio > 1) then + newsz = i + else + ! + ! We are not gaining + ! + newsz = newsz-1 end if + end if - if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then - newsz=i-1 - 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 + if (all(nlaggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + 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 end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit old_array_build_loop - end do old_array_build_loop - - if (newsz > 0) then - ! - ! We exited early from the build loop, need to fix - ! the size. - ! - allocate(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz-1 - call p%precv(i)%move_alloc(tprecv(i),info) - end do - call p%precv(iszv)%move_alloc(tprecv(newsz),info) - do i=newsz+1, iszv - call p%precv(i)%free(info) - end do - call move_alloc(tprecv,p%precv) - ! 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 - 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 + call psb_bcast(ictxt,newsz) + if (newsz > 0) & + & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) - else - - array_build_loop: do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - 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_aggrmap_bld(p%precv(i),& - & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& - & ilaggr,nlaggr,op_prol,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Map build') - goto 9999 - endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info + if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Map build') + goto 9999 + endif - ! - ! Check for early termination of aggregation loop. - ! - iaggsize = sum(nlaggr) - if (iaggsize <= casize) then - newsz = i - end if - - if (i>2) then - sizeratio = iaggsize - sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio - if (sizeratio < mnaggratio) then - if (sizeratio > 1) then - newsz = i - else - ! - ! We are not gaining - ! - newsz = newsz-1 - end if - end if - - if (all(nlaggr == p%precv(i-1)%map%naggr)) then - newsz=i-1 - 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 - end if - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) & - & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) - - if (info == psb_success_) call mld_aggrmat_asb(p%precv(i),& - & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& - & ilaggr,nlaggr,op_prol,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Map build') - goto 9999 - endif - - if (newsz > 0) exit array_build_loop - end do array_build_loop + if (newsz > 0) exit array_build_loop + end do array_build_loop - if (newsz > 0) then - ! - ! We exited early from the build loop, need to fix - ! the size. - ! - allocate(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz - call p%precv(i)%move_alloc(tprecv(i),info) - end do - do i=newsz+1, iszv - call p%precv(i)%free(info) - end do - call move_alloc(tprecv,p%precv) - ! 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 - 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 - end if + if (newsz > 0) then + ! + ! We exited early from the build loop, need to fix + ! the size. + ! + allocate(tprecv(newsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=1,newsz + call p%precv(i)%move_alloc(tprecv(i),info) + end do + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + ! 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 + 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 end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index f8012673..27599ffe 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -178,7 +178,7 @@ module mld_d_inner_mod end interface mld_dec_map_bld - interface mld_aggrmat_asb + interface mld_lev_mat_asb subroutine mld_d_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ use mld_d_prec_type, only : mld_d_onelev_type @@ -190,9 +190,8 @@ module mld_d_inner_mod type(psb_dspmat_type), intent(inout) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_d_lev_aggrmat_asb - end interface mld_aggrmat_asb + end interface mld_lev_mat_asb - abstract interface subroutine mld_daggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) diff --git a/tests/pdegen/mld_d_pde3d.f90 b/tests/pdegen/mld_d_pde3d.f90 index d6a62892..6a29ed84 100644 --- a/tests/pdegen/mld_d_pde3d.f90 +++ b/tests/pdegen/mld_d_pde3d.f90 @@ -261,6 +261,7 @@ program mld_d_pde3d call mld_precset(prec,'aggr_kind', prectype%aggrkind,info) call mld_precset(prec,'aggr_alg', prectype%aggr_alg,info) call mld_precset(prec,'aggr_ord', prectype%aggr_ord,info) + call mld_precset(prec,'aggr_filter', mld_filter_mat_, info) call psb_barrier(ictxt) t1 = psb_wtime() From 74ab1d540f2a62339078e52db12fa00c7334e313 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 30 Sep 2016 19:19:23 +0000 Subject: [PATCH 13/21] mld2p4-extaggr: mlprec/impl/Makefile mlprec/impl/mld_c_dec_map_bld.f90 mlprec/impl/mld_c_hierarchy_bld.f90 mlprec/impl/mld_c_lev_aggrmap_bld.f90 mlprec/impl/mld_c_lev_aggrmat_asb.f90 mlprec/impl/mld_caggrmap_bld.f90 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_d_bld_mlhier_array.f90 mlprec/impl/mld_d_dec_map_bld.f90.new mlprec/impl/mld_d_dec_map_bld.f90 mlprec/impl/mld_daggrmap_bld.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_smth_asb.f90 mlprec/impl/mld_dcoarse_bld.f90 mlprec/impl/mld_dprecinit.F90 mlprec/impl/mld_s_dec_map_bld.f90 mlprec/impl/mld_s_hierarchy_bld.f90 mlprec/impl/mld_s_lev_aggrmap_bld.f90 mlprec/impl/mld_s_lev_aggrmat_asb.f90 mlprec/impl/mld_saggrmap_bld.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_z_dec_map_bld.f90 mlprec/impl/mld_z_hierarchy_bld.f90 mlprec/impl/mld_z_lev_aggrmap_bld.f90 mlprec/impl/mld_z_lev_aggrmat_asb.f90 mlprec/impl/mld_zaggrmap_bld.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 New organization of aggregation routines. --- mlprec/impl/Makefile | 6 +- mlprec/impl/mld_c_dec_map_bld.f90 | 39 ++- mlprec/impl/mld_c_hierarchy_bld.f90 | 228 +++++++++++++++- mlprec/impl/mld_c_lev_aggrmap_bld.f90 | 148 ++++++++++ mlprec/impl/mld_c_lev_aggrmat_asb.f90 | 252 +++++++++++++++++ mlprec/impl/mld_caggrmap_bld.f90 | 29 +- mlprec/impl/mld_caggrmat_asb.f90 | 115 +------- mlprec/impl/mld_caggrmat_biz_asb.f90 | 25 +- mlprec/impl/mld_caggrmat_minnrg_asb.f90 | 29 +- mlprec/impl/mld_caggrmat_nosmth_asb.f90 | 31 +-- mlprec/impl/mld_caggrmat_smth_asb.f90 | 23 +- mlprec/impl/mld_d_bld_mlhier_array.f90 | 54 ++-- mlprec/impl/mld_d_dec_map_bld.f90 | 16 +- mlprec/impl/mld_d_dec_map_bld.f90.new | 343 ++++++++++++++++++++++++ mlprec/impl/mld_daggrmap_bld.f90 | 8 +- mlprec/impl/mld_daggrmat_asb.f90 | 14 +- mlprec/impl/mld_daggrmat_biz_asb.f90 | 2 +- mlprec/impl/mld_daggrmat_minnrg_asb.f90 | 6 +- mlprec/impl/mld_daggrmat_smth_asb.f90 | 2 +- mlprec/impl/mld_dcoarse_bld.f90 | 252 ++++------------- mlprec/impl/mld_dprecinit.F90 | 2 +- mlprec/impl/mld_s_dec_map_bld.f90 | 39 ++- mlprec/impl/mld_s_hierarchy_bld.f90 | 228 +++++++++++++++- mlprec/impl/mld_s_lev_aggrmap_bld.f90 | 148 ++++++++++ mlprec/impl/mld_s_lev_aggrmat_asb.f90 | 252 +++++++++++++++++ mlprec/impl/mld_saggrmap_bld.f90 | 29 +- mlprec/impl/mld_saggrmat_asb.f90 | 115 +------- mlprec/impl/mld_saggrmat_biz_asb.f90 | 25 +- mlprec/impl/mld_saggrmat_minnrg_asb.f90 | 29 +- mlprec/impl/mld_saggrmat_nosmth_asb.f90 | 31 +-- mlprec/impl/mld_saggrmat_smth_asb.f90 | 23 +- mlprec/impl/mld_z_dec_map_bld.f90 | 37 ++- mlprec/impl/mld_z_hierarchy_bld.f90 | 228 +++++++++++++++- mlprec/impl/mld_z_lev_aggrmap_bld.f90 | 148 ++++++++++ mlprec/impl/mld_z_lev_aggrmat_asb.f90 | 252 +++++++++++++++++ mlprec/impl/mld_zaggrmap_bld.f90 | 29 +- mlprec/impl/mld_zaggrmat_asb.f90 | 115 +------- mlprec/impl/mld_zaggrmat_biz_asb.f90 | 25 +- mlprec/impl/mld_zaggrmat_minnrg_asb.f90 | 29 +- mlprec/impl/mld_zaggrmat_nosmth_asb.f90 | 31 +-- mlprec/impl/mld_zaggrmat_smth_asb.f90 | 23 +- mlprec/mld_c_inner_mod.f90 | 30 ++- mlprec/mld_d_inner_mod.f90 | 30 ++- mlprec/mld_s_inner_mod.f90 | 30 ++- mlprec/mld_z_inner_mod.f90 | 30 ++- 45 files changed, 2578 insertions(+), 1002 deletions(-) create mode 100644 mlprec/impl/mld_c_lev_aggrmap_bld.f90 create mode 100644 mlprec/impl/mld_c_lev_aggrmat_asb.f90 create mode 100644 mlprec/impl/mld_d_dec_map_bld.f90.new create mode 100644 mlprec/impl/mld_s_lev_aggrmap_bld.f90 create mode 100644 mlprec/impl/mld_s_lev_aggrmat_asb.f90 create mode 100644 mlprec/impl/mld_z_lev_aggrmap_bld.f90 create mode 100644 mlprec/impl/mld_z_lev_aggrmat_asb.f90 diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index 3db4d32f..6b7c2bf5 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -32,19 +32,19 @@ SINNEROBJS= mld_scoarse_bld.o mld_smlprec_bld.o mld_s_bld_mlhier_aggsize.o mld mld_s_ml_prec_bld.o mld_s_hierarchy_bld.o \ mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o mld_saggrmap_bld.o \ mld_s_dec_map_bld.o mld_smlprec_aply.o mld_saggrmat_asb.o \ - $(SMPFOBJS) mld_s_extprol_bld.o + $(SMPFOBJS) mld_s_extprol_bld.o mld_s_lev_aggrmap_bld.o mld_s_lev_aggrmat_asb.o ZINNEROBJS= mld_zcoarse_bld.o mld_zmlprec_bld.o mld_z_bld_mlhier_aggsize.o mld_z_bld_mlhier_array.o \ mld_z_ml_prec_bld.o mld_z_hierarchy_bld.o \ mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \ mld_z_dec_map_bld.o mld_zmlprec_aply.o mld_zaggrmat_asb.o \ - $(ZMPFOBJS) mld_z_extprol_bld.o + $(ZMPFOBJS) mld_z_extprol_bld.o mld_z_lev_aggrmap_bld.o mld_z_lev_aggrmat_asb.o CINNEROBJS= mld_ccoarse_bld.o mld_cmlprec_bld.o mld_c_bld_mlhier_aggsize.o mld_c_bld_mlhier_array.o \ mld_c_ml_prec_bld.o mld_c_hierarchy_bld.o \ mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \ mld_c_dec_map_bld.o mld_cmlprec_aply.o mld_caggrmat_asb.o \ - $(CMPFOBJS) mld_c_extprol_bld.o + $(CMPFOBJS) mld_c_extprol_bld.o mld_c_lev_aggrmap_bld.o mld_c_lev_aggrmat_asb.o INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS) diff --git a/mlprec/impl/mld_c_dec_map_bld.f90 b/mlprec/impl/mld_c_dec_map_bld.f90 index 35452b80..0084692d 100644 --- a/mlprec/impl/mld_c_dec_map_bld.f90 +++ b/mlprec/impl/mld_c_dec_map_bld.f90 @@ -54,12 +54,12 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! Local variables integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& - & ideg(:), idxs(:) + & ideg(:), idxs(:), tmpaggr(:) complex(psb_spk_), allocatable :: val(:), diag(:) integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip type(psb_c_csr_sparse_mat) :: acsr real(psb_spk_) :: cpling, tcl - logical :: recovery, candidate + logical :: disjoint integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -138,20 +138,15 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if end if enddo - if (ip < 1) then - write(0,*) "Should at least contain the node itself ! " - cycle step1 - end if - candidate = .true. - do k=1, ip - candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) - end do - if (candidate) then - ! - ! If the whole strongly coupled neighborhood of I is - ! as yet unconnected, turn it into the next aggregate - ! + ! + ! If the whole strongly coupled neighborhood of I is + ! as yet unconnected, turn it into the next aggregate. + ! Same if ip==0 (in which case, neighborhood only + ! contains I even if it does not look from matrix) + ! + disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) + if (disjoint) then icnt = icnt + 1 naggr = naggr + 1 do k=1, ip @@ -161,6 +156,7 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if endif enddo step1 + if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),& & ' Check 1:',count(ilaggr == -(nr+1)) @@ -168,7 +164,8 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! ! Phase two: join the neighbours - ! + ! + tmpaggr = ilaggr step2: do ii=1,nr i = idxs(ii) @@ -189,7 +186,7 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) j = icol(k) if ((1<=j).and.(j<=nr)) then if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& - & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then + & .and. (tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then ip = k cpling = abs(val(k)) end if @@ -208,7 +205,7 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) step3: do ii=1,nr i = idxs(ii) - if (ilaggr(i) == -(nr+1)) then + if (ilaggr(i) < 0) then call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -216,10 +213,10 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if ! - ! Find the most strongly connected neighbour that is - ! already aggregated, if any, and join its aggregate + ! Find its strongly connected neighbourhood not + ! already aggregated, and make it into a new aggregate. ! - cpling = szero + cpling = dzero ip = 0 do k=1, nz j = icol(k) diff --git a/mlprec/impl/mld_c_hierarchy_bld.f90 b/mlprec/impl/mld_c_hierarchy_bld.f90 index 46977d3c..04d8548b 100644 --- a/mlprec/impl/mld_c_hierarchy_bld.f90 +++ b/mlprec/impl/mld_c_hierarchy_bld.f90 @@ -94,9 +94,13 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! Local Variables integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs - real(psb_spk_) :: mnaggratio - integer(psb_ipk_) :: ipv(mld_ifpsz_), val + integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize + real(psb_spk_) :: mnaggratio, sizeratio + class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_sml_parms) :: baseparms, medparms, coarseparms + integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) + type(psb_cspmat_type) :: op_prol + type(mld_c_onelev_type), allocatable :: tprecv(:) integer(psb_ipk_) :: int_err(5) character :: upd_ integer(psb_ipk_) :: debug_level, debug_unit @@ -191,10 +195,23 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) goto 9999 endif + ! + ! The strategy: + ! 1. The maximum number of levels should be already encoded in the + ! size of the array; + ! 2. If the user did not specify anything, then a default coarse size + ! is generated, and the number of levels is set to the maximum; + ! 3. If the number of levels has been specified, make sure it's capped + ! at the maximum; + ! 4. If the size of the array is different from target number of levels, + ! reallocate; + ! 5. Build the matrix hierarchy, stopping early if either the target + ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! threshold. + ! + + if (nplevs <= 0) then - ! - ! This should become the default strategy, we specify a target aggregation size. - ! if (casize <=0) then ! ! Default to the cubic root of the size at base level. @@ -204,15 +221,200 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) casize = max(casize,ione) casize = casize*40_psb_ipk_ end if - call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info) - else + nplevs = mxplevs + end if + + nplevs = max(itwo,min(nplevs,mxplevs)) + + 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 + + ! + ! First set desired number of levels + ! + if (iszv /= nplevs) then + allocate(tprecv(nplevs),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + tprecv(1)%parms = baseparms + allocate(tprecv(1)%sm,source=base_sm,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=2,nplevs-1 + tprecv(i)%parms = medparms + allocate(tprecv(i)%sm,source=med_sm,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + end do + tprecv(nplevs)%parms = coarseparms + allocate(tprecv(nplevs)%sm,source=coarse_sm,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,iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + iszv = size(p%precv) + end if + + ! + ! Finest level first; remember to fix base_a and base_desc + ! + p%precv(1)%base_a => a + p%precv(1)%base_desc => desc_a + newsz = 0 + array_build_loop: do i=2, iszv + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + 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 ! - ! Oldstyle with fixed number of levels. + if (info == psb_success_) call mld_aggrmap_bld(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Map build') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + + ! - nplevs = max(itwo,min(nplevs,mxplevs)) - call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info) + ! Check for early termination of aggregation loop. + ! + iaggsize = sum(nlaggr) + if (iaggsize <= casize) then + newsz = i + end if + + if (i>2) then + sizeratio = iaggsize + sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio + if (sizeratio < mnaggratio) then + if (sizeratio > 1) then + newsz = i + else + ! + ! We are not gaining + ! + newsz = newsz-1 + end if + end if + + if (all(nlaggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + 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 + end if + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) & + & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) + + if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Map build') + goto 9999 + endif + + if (newsz > 0) exit array_build_loop + end do array_build_loop + + if (newsz > 0) then + ! + ! We exited early from the build loop, need to fix + ! the size. + ! + allocate(tprecv(newsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=1,newsz + call p%precv(i)%move_alloc(tprecv(i),info) + end do + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + ! 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 + 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 end if - + + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) @@ -220,7 +422,7 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) endif iszv = size(p%precv) - + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Exiting with',iszv,' levels' diff --git a/mlprec/impl/mld_c_lev_aggrmap_bld.f90 b/mlprec/impl/mld_c_lev_aggrmap_bld.f90 new file mode 100644 index 00000000..0e2034bf --- /dev/null +++ b/mlprec/impl/mld_c_lev_aggrmap_bld.f90 @@ -0,0 +1,148 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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_ccoarse_bld.f90 +! +! Subroutine: mld_ccoarse_bld +! Version: real +! +! This routine builds the matrix associated to the current level of the +! multilevel preconditioner from the matrix associated to the previous level, +! by using a smoothed aggregation technique (therefore, it also builds the +! prolongation and restriction operators mapping the current level to the +! previous one and vice versa). Then the routine builds the base preconditioner +! at the current level. +! The current level is regarded as the coarse one, while the previous as +! the fine one. This is in agreement with the fact that the routine is called, +! by mld_mlprec_bld, only on levels >=2. +! +! +! Arguments: +! a - type(psb_cspmat_type). +! The sparse matrix structure containing the local part of the +! fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_c_onelev_type), input/output. +! The 'one-level' data structure containing the local part +! of the base preconditioner to be built as well as +! information concerning the prolongator and its transpose. +! info - integer, output. +! Error code. +! +subroutine mld_c_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + + use psb_base_mod + use mld_c_inner_mod, mld_protect_name => mld_c_lev_aggrmap_bld + + implicit none + + ! Arguments + type(mld_c_onelev_type), intent(inout), target :: p + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_cspmat_type), intent(out) :: op_prol + integer(psb_ipk_), intent(out) :: info + + + ! Local variables + character(len=20) :: name + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nzl, ntaggr + integer(psb_ipk_) :: debug_level, debug_unit + + name='mld_c_lev_aggrmap_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ictxt = desc_a%get_context() + call psb_info(ictxt,me,np) + + call mld_check_def(p%parms%ml_type,'Multilevel type',& + & mld_mult_ml_,is_legal_ml_type) + call mld_check_def(p%parms%aggr_alg,'Aggregation',& + & mld_dec_aggr_,is_legal_ml_aggr_alg) + call mld_check_def(p%parms%aggr_ord,'Ordering',& + & mld_aggr_ord_nat_,is_legal_ml_aggr_ord) + call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs) + + select case(p%parms%aggr_alg) + case (mld_dec_aggr_, mld_sym_dec_aggr_) + + ! + ! Build a mapping between the row indices of the fine-level matrix + ! and the row indices of the coarse-level matrix, according to a decoupled + ! aggregation algorithm. This also defines a tentative prolongator from + ! the coarse to the fine level. + ! + call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& + & a,desc_a,ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') + goto 9999 + end if + + case (mld_bcmatch_aggr_) + write(0,*) 'Matching is not implemented yet ' + info = -1111 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) + goto 9999 + + case default + + info = -1 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) + goto 9999 + + end select + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_c_lev_aggrmap_bld diff --git a/mlprec/impl/mld_c_lev_aggrmat_asb.f90 b/mlprec/impl/mld_c_lev_aggrmat_asb.f90 new file mode 100644 index 00000000..8dbb2370 --- /dev/null +++ b/mlprec/impl/mld_c_lev_aggrmat_asb.f90 @@ -0,0 +1,252 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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_ccoarse_bld.f90 +! +! Subroutine: mld_ccoarse_bld +! Version: real +! +! This routine builds the matrix associated to the current level of the +! multilevel preconditioner from the matrix associated to the previous level, +! by using a smoothed aggregation technique (therefore, it also builds the +! prolongation and restriction operators mapping the current level to the +! previous one and vice versa). Then the routine builds the base preconditioner +! at the current level. +! The current level is regarded as the coarse one, while the previous as +! the fine one. This is in agreement with the fact that the routine is called, +! by mld_mlprec_bld, only on levels >=2. +! +! +! Arguments: +! a - type(psb_cspmat_type). +! The sparse matrix structure containing the local part of the +! fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_c_onelev_type), input/output. +! The 'one-level' data structure containing the local part +! of the base preconditioner to be built as well as +! information concerning the prolongator and its transpose. +! info - integer, output. +! Error code. +! +subroutine mld_c_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + + use psb_base_mod + use mld_c_inner_mod, mld_protect_name => mld_c_lev_aggrmat_asb + + implicit none + + ! Arguments + type(mld_c_onelev_type), intent(inout), target :: p + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:) + type(psb_cspmat_type), intent(inout) :: op_prol + integer(psb_ipk_), intent(out) :: info + + + ! Local variables + character(len=20) :: name + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + type(psb_cspmat_type) :: ac, op_restr + type(psb_c_coo_sparse_mat) :: acoo, bcoo + type(psb_c_csr_sparse_mat) :: acsr1 + integer(psb_ipk_) :: nzl, ntaggr + integer(psb_ipk_) :: debug_level, debug_unit + + name='mld_ccoarse_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ictxt = desc_a%get_context() + call psb_info(ictxt,me,np) + + call mld_check_def(p%parms%aggr_kind,'Smoother',& + & mld_smooth_prol_,is_legal_ml_aggr_kind) + call mld_check_def(p%parms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_legal_ml_coarse_mat) + call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',& + & mld_no_filter_mat_,is_legal_aggr_filter) + call mld_check_def(p%parms%smoother_pos,'smooth_pos',& + & mld_pre_smooth_,is_legal_ml_smooth_pos) + call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',& + & mld_eig_est_,is_legal_ml_aggr_omega_alg) + call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',& + & mld_max_norm_,is_legal_ml_aggr_eig) + call mld_check_def(p%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega) + + + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by mld_aggrmap_bld and applying the aggregation + ! algorithm specified by p%iprcparm(mld_aggr_kind_) + ! + call mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') + goto 9999 + end if + + + ! Common code refactored here. + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + call ac%mv_to(bcoo) + if (p%parms%clean_zeros) call bcoo%clean_zeros(info) + nzl = bcoo%get_nzeros() + + 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 + ! + ! Clip to local rows. + ! + call op_restr%set_nrows(p%desc_ac%get_local_rows()) + + 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + p%base_a => p%ac + p%base_desc => p%desc_ac + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_c_lev_aggrmat_asb diff --git a/mlprec/impl/mld_caggrmap_bld.f90 b/mlprec/impl/mld_caggrmap_bld.f90 index e2ed909b..365c6a87 100644 --- a/mlprec/impl/mld_caggrmap_bld.f90 +++ b/mlprec/impl/mld_caggrmap_bld.f90 @@ -79,7 +79,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) +subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmap_bld @@ -93,13 +93,14 @@ subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_cspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_), allocatable :: ils(:), neigh(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m,naggrm1, naggrp1, ntaggr type(psb_cspmat_type) :: atmp, atrans - logical :: recovery + type(psb_c_coo_sparse_mat) :: tmpcoo integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -151,6 +152,28 @@ subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) goto 9999 end if + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + 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 + + call tmpcoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + tmpcoo%val(i) = cone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_sorted() ! At this point this is in row-major + call op_prol%mv_from(tmpcoo) + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_caggrmat_asb.f90 b/mlprec/impl/mld_caggrmat_asb.f90 index 82d654e0..1cef24ee 100644 --- a/mlprec/impl/mld_caggrmat_asb.f90 +++ b/mlprec/impl/mld_caggrmat_asb.f90 @@ -98,7 +98,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_caggrmat_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_asb @@ -109,11 +109,12 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_sml_parms), intent(inout) :: parms type(mld_c_onelev_type), intent(inout), target :: p + type(psb_cspmat_type), intent(inout) :: ac, op_prol,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables - 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(psb_ipk_) :: nzl,ntaggr, err_act @@ -165,116 +166,6 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - - - ntaggr = sum(nlaggr) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call ac%mv_to(bcoo) - if (p%parms%clean_zeros) call bcoo%clean_zeros(info) - nzl = bcoo%get_nzeros() - - 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 - ! - ! Clip to local rows. - ! - call op_restr%set_nrows(p%desc_ac%get_local_rows()) - - 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 307ca827..794bb9f1 100644 --- a/mlprec/impl/mld_caggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_caggrmat_biz_asb.f90 @@ -89,7 +89,8 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_cspmat_type), intent(inout) :: op_prol + type(psb_cspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -128,19 +129,8 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - naggrm1 = sum(nlaggr(1:me)) - naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (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. ! @@ -157,17 +147,10 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr end if ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,naggr,ncol) - do i=1,nrow - tmpcoo%val(i) = cone - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(nrow) - call tmpcoo%set_dupl(psb_dupl_add_) - + call op_prol%mv_to(tmpcoo) call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + if (info /= psb_success_) goto 9999 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 7ebcb689..4884252a 100644 --- a/mlprec/impl/mld_caggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 @@ -108,8 +108,9 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sml_parms), intent(inout) :: parms - type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(inout) :: op_prol + type(psb_cspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -167,14 +168,6 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re filter_mat = (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. ! @@ -209,20 +202,10 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - tmpcoo%val(i) = cone - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(ncol) - call tmpcoo%set_dupl(psb_dupl_add_) - call tmpcoo%set_asb() + call op_prol%mv_to(tmpcoo) call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') -!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') - if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_) if (info /= psb_success_) then @@ -276,7 +259,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re call am3%mv_to(acsr3) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = czero do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -454,7 +437,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re omp = omp/oden ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = czero do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) diff --git a/mlprec/impl/mld_caggrmat_nosmth_asb.f90 b/mlprec/impl/mld_caggrmat_nosmth_asb.f90 index 91b01614..b47c1dd7 100644 --- a/mlprec/impl/mld_caggrmat_nosmth_asb.f90 +++ b/mlprec/impl/mld_caggrmat_nosmth_asb.f90 @@ -92,7 +92,8 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_cspmat_type), intent(inout) :: op_prol + type(psb_cspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -124,34 +125,12 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ntaggr = sum(nlaggr) naggrm1=sum(nlaggr(1:me)) - 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 - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,nrow - acoo%val(i) = cone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - - 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(acoo) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call op_prol%transp(op_restr) - + if (info /= psb_success_) goto 9999 + call op_prol%transp(op_restr) + call a%cp_to(ac_coo) nzt = ac_coo%get_nzeros() diff --git a/mlprec/impl/mld_caggrmat_smth_asb.f90 b/mlprec/impl/mld_caggrmat_smth_asb.f90 index 0f24e6d6..83ad51ad 100644 --- a/mlprec/impl/mld_caggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_caggrmat_smth_asb.f90 @@ -104,7 +104,8 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_cspmat_type), intent(inout) :: op_prol + type(psb_cspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -147,14 +148,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest naggrp1 = sum(nlaggr(1:me+1)) filter_mat = (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. ! @@ -172,17 +166,10 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest end if ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - tmpcoo%val(i) = cone - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(ncol) - call tmpcoo%set_dupl(psb_dupl_add_) - call tmpcoo%set_sorted() ! At this point this is in row-major + call op_prol%mv_to(tmpcoo) call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + if (info /= psb_success_) goto 9999 if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_d_bld_mlhier_array.f90 b/mlprec/impl/mld_d_bld_mlhier_array.f90 index bd0a0e77..3618de1b 100644 --- a/mlprec/impl/mld_d_bld_mlhier_array.f90 +++ b/mlprec/impl/mld_d_bld_mlhier_array.f90 @@ -37,25 +37,23 @@ !!$ !!$ -subroutine mld_d_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) +subroutine mld_d_bld_mlhier_array(nplevs,a,desc_a,precv,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_d_bld_mlhier_array use mld_d_prec_mod implicit none - integer(psb_ipk_), intent(inout) :: nplevs, casize - real(psb_dpk_) :: mnaggratio + integer(psb_ipk_), intent(inout) :: nplevs type(psb_dspmat_type),intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_d_onelev_type),intent(inout), allocatable, target :: precv(:) integer(psb_ipk_), intent(out) :: info ! Local integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv, iaggsize + integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv integer(psb_ipk_) :: ipv(mld_ifpsz_), val class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm type(mld_dml_parms) :: baseparms, medparms, coarseparms type(mld_d_onelev_type), allocatable :: tprecv(:) - real(psb_dpk_) :: sizeratio integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -180,45 +178,27 @@ subroutine mld_d_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) & write(debug_unit,*) me,' ',trim(name),& & 'Return from ',i,' call to mlprcbld ',info - iaggsize = sum(precv(i)%map%naggr) - if (iaggsize <= casize) then - newsz = i - end if - - if (i>2) then - sizeratio = iaggsize - sizeratio = sum(precv(i-1)%map%naggr)/sizeratio - if (sizeratio < mnaggratio) then - if (sizeratio > 1) then - newsz = i - else - ! - ! We are not gaining - ! - newsz = newsz-1 - end if - end if - + if (i>2) then if (all(precv(i)%map%naggr == precv(i-1)%map%naggr)) then newsz=i-1 - 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 end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) exit array_build_loop end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop end do array_build_loop 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(tprecv(newsz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& diff --git a/mlprec/impl/mld_d_dec_map_bld.f90 b/mlprec/impl/mld_d_dec_map_bld.f90 index c4128a19..ecbf5a8b 100644 --- a/mlprec/impl/mld_d_dec_map_bld.f90 +++ b/mlprec/impl/mld_d_dec_map_bld.f90 @@ -56,10 +56,10 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& & ideg(:), idxs(:), tmpaggr(:) real(psb_dpk_), allocatable :: val(:), diag(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip, nisolate,nthird + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip type(psb_d_csr_sparse_mat) :: acsr real(psb_dpk_) :: cpling, tcl - logical :: recovery, disjoint + logical :: disjoint integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -114,7 +114,6 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! naggr = 0 icnt = 0 - nisolate = 0 step1: do ii=1, nr i = idxs(ii) @@ -140,11 +139,6 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if enddo -!!$ if (ip <= 1) then -!!$ nisolate = nisolate + 1 -!!$ cycle step1 -!!$ end if - ! ! If the whole strongly coupled neighborhood of I is ! as yet unconnected, turn it into the next aggregate. @@ -193,7 +187,6 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) if ((1<=j).and.(j<=nr)) then if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& & .and. (tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then -!!$ if ((tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then ip = k cpling = abs(val(k)) end if @@ -209,12 +202,10 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! ! Phase three: sweep over leftovers, if any ! - nthird = 0 step3: do ii=1,nr i = idxs(ii) if (ilaggr(i) < 0) then - nthird = nthird + 1 call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -288,8 +279,7 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) nlaggr(:) = 0 nlaggr(me+1) = naggr call psb_sum(ictxt,nlaggr(1:np)) - - !write(*,*) me,'Info from dec_map_bld: ',naggr,nisolate,nthird + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_d_dec_map_bld.f90.new b/mlprec/impl/mld_d_dec_map_bld.f90.new new file mode 100644 index 00000000..67e4437b --- /dev/null +++ b/mlprec/impl/mld_d_dec_map_bld.f90.new @@ -0,0 +1,343 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ + +subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) + + use psb_base_mod + use mld_d_inner_mod, mld_protect_name => mld_d_dec_map_bld + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: iorder + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), intent(in) :: theta + integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + integer(psb_ipk_), intent(out) :: info + + ! Local variables + integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& + & ideg(:), idxs(:) + real(psb_dpk_), allocatable :: val(:), diag(:) + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii + type(psb_d_csr_sparse_mat) :: acsr + real(psb_dpk_) :: cpling, tcl + logical :: recovery + integer(psb_ipk_) :: debug_level, debug_unit,err_act + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: nrow, ncol, n_ne + character(len=20) :: name, ch_err + + if (psb_get_errstatus() /= 0) return + info=psb_success_ + name = 'mld_dec_map_bld' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ! + ictxt=desc_a%get_context() + call psb_info(ictxt,me,np) + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + nr = a%get_nrows() + allocate(ilaggr(nr),neigh(nr),ideg(nr),idxs(nr),stat=info) + if(info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nr,izero,izero,izero,izero/),& + & a_err='integer') + goto 9999 + end if + + diag = a%get_diag(info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getdiag') + goto 9999 + end if + + if (iorder == mld_aggr_ord_nat_) then + do i=1, nr + ilaggr(i) = -(nr+1) + idxs(i) = i + end do + else + call a%cp_to(acsr) + do i=1, nr + ilaggr(i) = -(nr+1) + ideg(i) = acsr%irp(i+1) - acsr%irp(i) + end do + call acsr%free() + call psb_msort(ideg,ix=idxs,dir=psb_sort_down_) + end if + ! Note: -(nr+1) Untouched as yet + ! -i 1<=i<=nr Adjacent to aggregate i + ! i 1<=i<=nr Belonging to aggregate i + ! + ! Phase one: group nodes together. + ! Very simple minded strategy. + ! + naggr = 0 + nlp = 0 + do + icnt = 0 + do ii=1, nr + i = idxs(ii) + if (ilaggr(i) == -(nr+1)) then + ! + ! 1. Untouched nodes are marked >0 together + ! with their neighbours + ! + icnt = icnt + 1 + naggr = naggr + 1 + ilaggr(i) = naggr + + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='csget') + goto 9999 + end if + + do k=1, nz + j = icol(k) + if ((1<=j).and.(j<=nr)) then + ilg = ilaggr(j) + if ((ilg<0).and.(i /= j)) then + if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then + ilaggr(j) = naggr + else + ilaggr(j) = -naggr + endif + end if + end if + enddo + + ! + ! 2. Untouched neighbours of these nodes are marked <0. + ! + call a%get_neigh(i,neigh,n_ne,info,lev=2_psb_ipk_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_neigh') + goto 9999 + end if + + do n = 1, n_ne + m = neigh(n) + if ((1<=m).and.(m<=nr)) then + if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr + endif + enddo + endif + enddo + nlp = nlp + 1 + if (icnt == 0) exit + enddo + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & ' Check 1:',count(ilaggr == -(nr+1)) + end if + + ! + ! Phase two: sweep over leftovers. + ! + allocate(ils(nr),stat=info) + if(info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/naggr+10,izero,izero,izero,izero/),& + & a_err='integer') + goto 9999 + end if + + do i=1, size(ils) + ils(i) = 0 + end do + do i=1, nr + n = ilaggr(i) + if (n>0) then + if (n>naggr) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?') + goto 9999 + else + ils(n) = ils(n) + 1 + end if + + end if + end do + if (debug_level >= psb_debug_outer_) then + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 1: number of aggregates ',naggr + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 1: nodes aggregated ',sum(ils) + end if + + recovery=.false. + do i=1, nr + if (ilaggr(i) < 0) then + ! + ! Now some silly rule to break ties: + ! Group with adjacent aggregate. + ! + isz = nr+1 + ia = -1 + cpling = dzero + call a%csget(i,i,nz,irow,icol,val,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_sp_getrow') + goto 9999 + end if + + do j=1, nz + k = icol(j) + if ((1<=k).and.(k<=nr).and.(k /= i)) then + tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k))) + if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then +!!$ if (tcl > theta) then + n = ilaggr(k) + if (n>0) then + if (n>naggr) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') + goto 9999 + end if + + if ((abs(val(j))>cpling) .or. & + & ((abs(val(j)) == cpling).and. (ils(n) < isz))) then +!!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then + ia = n + isz = ils(n) + cpling = abs(val(j)) +!!$ cpling = tcl + endif + endif + endif + end if + enddo + + if (ia == -1) then + ! At this point, the easiest thing is to start a new aggregate + naggr = naggr + 1 + ilaggr(i) = naggr + ils(ilaggr(i)) = 1 + + else + + ilaggr(i) = ia + + if (ia>naggr) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr ? ') + goto 9999 + end if + ils(ia) = ils(ia) + 1 + endif + + end if + end do + if (debug_level >= psb_debug_outer_) then + if (recovery) then + write(debug_unit,*) me,' ',trim(name),& + & 'Had to recover from strange situation in loc_aggregate.' + write(debug_unit,*) me,' ',trim(name),& + & 'Perhaps an unsymmetric pattern?' + endif + write(debug_unit,*) me,' ',trim(name),& + & 'Phase 2: number of aggregates ',naggr,sum(ils) + do i=1, naggr + write(debug_unit,*) me,' ',trim(name),& + & 'Size of aggregate ',i,' :',count(ilaggr == i), ils(i) + enddo + write(debug_unit,*) me,' ',trim(name),& + & maxval(ils(1:naggr)) + write(debug_unit,*) me,' ',trim(name),& + & 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' + end if + + if (count(ilaggr<0) >0) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Fatal error: some leftovers') + goto 9999 + endif + + deallocate(ils,neigh,stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + if (naggr > ncol) then + write(0,*) name,'Error : naggr > ncol',naggr,ncol + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Fatal error: naggr>ncol') + goto 9999 + end if + + call psb_realloc(ncol,ilaggr,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(nlaggr(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/np,izero,izero,izero,izero/),& + & a_err='integer') + goto 9999 + end if + + nlaggr(:) = 0 + nlaggr(me+1) = naggr + call psb_sum(ictxt,nlaggr(1:np)) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine mld_d_dec_map_bld + diff --git a/mlprec/impl/mld_daggrmap_bld.f90 b/mlprec/impl/mld_daggrmap_bld.f90 index de053aa6..f8e6d7cc 100644 --- a/mlprec/impl/mld_daggrmap_bld.f90 +++ b/mlprec/impl/mld_daggrmap_bld.f90 @@ -92,8 +92,8 @@ subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_pro real(psb_dpk_), intent(in) :: theta type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a - type(psb_dspmat_type), intent(out) :: op_prol integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_dspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info ! Local variables @@ -152,14 +152,12 @@ subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_pro goto 9999 end if - naggr = nlaggr(me+1) - ntaggr = sum(nlaggr) - + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) 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 diff --git a/mlprec/impl/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 index dd8dd9e4..2c7ab573 100644 --- a/mlprec/impl/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -110,9 +110,9 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms -!!$ type(mld_d_onelev_type), intent(inout), target :: p - integer(psb_ipk_), intent(out) :: info + type(mld_d_onelev_type), intent(inout), target :: p type(psb_dspmat_type), intent(inout) :: ac, op_prol,op_restr + integer(psb_ipk_), intent(out) :: info ! Local variables type(psb_d_coo_sparse_mat) :: acoo, bcoo @@ -134,26 +134,26 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf call psb_info(ictxt, me, np) - select case (parms%aggr_kind) + select case (p%parms%aggr_kind) case (mld_no_smooth_) call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& - & parms,ac,op_prol,op_restr,info) + & p%parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & - & parms,ac,op_prol,op_restr,info) + & p%parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & - & parms,ac,op_prol,op_restr,info) + & p%parms,ac,op_prol,op_restr,info) case(mld_min_energy_) call mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & - & parms,ac,op_prol,op_restr,info) + & p%parms,ac,op_prol,op_restr,info) case default info = psb_err_internal_error_ diff --git a/mlprec/impl/mld_daggrmat_biz_asb.f90 b/mlprec/impl/mld_daggrmat_biz_asb.f90 index 9d8dfa79..3e7d2a8a 100644 --- a/mlprec/impl/mld_daggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_daggrmat_biz_asb.f90 @@ -89,7 +89,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(inout) :: op_prol + type(psb_dspmat_type), intent(inout) :: op_prol type(psb_dspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info diff --git a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 index a08ab607..965443ca 100644 --- a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 @@ -108,7 +108,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_dml_parms), intent(inout) :: parms + type(mld_dml_parms), intent(inout) :: parms type(psb_dspmat_type), intent(inout) :: op_prol type(psb_dspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info @@ -259,7 +259,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re call am3%mv_to(acsr3) ! Compute omega_int - ommx = cmplx(dzero,dzero) + ommx = dzero do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -437,7 +437,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re omp = omp/oden ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! Compute omega_int - ommx = cmplx(dzero,dzero) + ommx = dzero do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) diff --git a/mlprec/impl/mld_daggrmat_smth_asb.f90 b/mlprec/impl/mld_daggrmat_smth_asb.f90 index 46b34133..455a7f2a 100644 --- a/mlprec/impl/mld_daggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_daggrmat_smth_asb.f90 @@ -148,7 +148,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest naggrp1 = sum(nlaggr(1:me+1)) filter_mat = (parms%aggr_filter == mld_filter_mat_) - + ! ! naggr: number of local aggregates ! nrow: local rows. ! diff --git a/mlprec/impl/mld_dcoarse_bld.f90 b/mlprec/impl/mld_dcoarse_bld.f90 index b439d393..b52c4215 100644 --- a/mlprec/impl/mld_dcoarse_bld.f90 +++ b/mlprec/impl/mld_dcoarse_bld.f90 @@ -83,229 +83,69 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info) integer(psb_mpik_) :: ictxt, np, me integer(psb_ipk_) :: err_act integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) - 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(psb_ipk_) :: nzl, ntaggr - integer(psb_ipk_) :: debug_level, debug_unit name='mld_dcoarse_bld' if (psb_get_errstatus().ne.0) return call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - info = psb_success_ + info = psb_success_ ictxt = desc_a%get_context() call psb_info(ictxt,me,np) - - if (.true.) then - call mld_aggrmap_bld(p,& - & a,desc_a,ilaggr,nlaggr,op_prol,info) - else - call mld_check_def(p%parms%ml_type,'Multilevel type',& - & mld_mult_ml_,is_legal_ml_type) - call mld_check_def(p%parms%aggr_alg,'Aggregation',& - & mld_dec_aggr_,is_legal_ml_aggr_alg) - call mld_check_def(p%parms%aggr_ord,'Ordering',& - & mld_aggr_ord_nat_,is_legal_ml_aggr_ord) - call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs) - - select case(p%parms%aggr_alg) - case (mld_dec_aggr_, mld_sym_dec_aggr_) - - ! - ! Build a mapping between the row indices of the fine-level matrix - ! and the row indices of the coarse-level matrix, according to a decoupled - ! aggregation algorithm. This also defines a tentative prolongator from - ! the coarse to the fine level. - ! - call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& - & a,desc_a,ilaggr,nlaggr,op_prol,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') - goto 9999 - end if - - case (mld_bcmatch_aggr_) - write(0,*) 'Matching is not implemented yet ' - info = -1111 - call psb_errpush(psb_err_input_value_invalid_i_,name,& - & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) - goto 9999 - - case default - - info = -1 - call psb_errpush(psb_err_input_value_invalid_i_,name,& - & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) - goto 9999 - - end select - end if - if(info /= psb_success_) then + call mld_check_def(p%parms%ml_type,'Multilevel type',& + & mld_mult_ml_,is_legal_ml_type) + call mld_check_def(p%parms%aggr_alg,'Aggregation',& + & mld_dec_aggr_,is_legal_ml_aggr_alg) + call mld_check_def(p%parms%aggr_ord,'Ordering',& + & mld_aggr_ord_nat_,is_legal_ml_aggr_ord) + call mld_check_def(p%parms%aggr_kind,'Smoother',& + & mld_smooth_prol_,is_legal_ml_aggr_kind) + call mld_check_def(p%parms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_legal_ml_coarse_mat) + call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',& + & mld_no_filter_mat_,is_legal_aggr_filter) + call mld_check_def(p%parms%smoother_pos,'smooth_pos',& + & mld_pre_smooth_,is_legal_ml_smooth_pos) + call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',& + & mld_eig_est_,is_legal_ml_aggr_omega_alg) + call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',& + & mld_max_norm_,is_legal_ml_aggr_eig) + call mld_check_def(p%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) + call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs) + + + ! + ! Build a mapping between the row indices of the fine-level matrix + ! and the row indices of the coarse-level matrix, according to a decoupled + ! aggregation algorithm. This also defines a tentative prolongator from + ! the coarse to the fine level. + ! + call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& + & a,desc_a,ilaggr,nlaggr,info) + + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') goto 9999 end if - - if (.true.) then - call mld_aggrmat_asb(p,& - & a,desc_a,ilaggr,nlaggr,op_prol,info) - else - - - call mld_check_def(p%parms%aggr_kind,'Smoother',& - & mld_smooth_prol_,is_legal_ml_aggr_kind) - call mld_check_def(p%parms%coarse_mat,'Coarse matrix',& - & mld_distr_mat_,is_legal_ml_coarse_mat) - call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',& - & mld_no_filter_mat_,is_legal_aggr_filter) - call mld_check_def(p%parms%smoother_pos,'smooth_pos',& - & mld_pre_smooth_,is_legal_ml_smooth_pos) - call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',& - & mld_eig_est_,is_legal_ml_aggr_omega_alg) - call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',& - & mld_max_norm_,is_legal_ml_aggr_eig) - call mld_check_def(p%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) - - - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by mld_aggrmap_bld and applying the aggregation - ! algorithm specified by p%iprcparm(mld_aggr_kind_) - ! - call mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info) - - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') - goto 9999 - end if - - - ! Common code refactored here. - - ntaggr = sum(nlaggr) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call ac%mv_to(bcoo) - if (p%parms%clean_zeros) call bcoo%clean_zeros(info) - nzl = bcoo%get_nzeros() - - 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 - ! - ! Clip to local rows. - ! - call op_restr%set_nrows(p%desc_ac%get_local_rows()) - - 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 - ! - ! Fix the base_a and base_desc pointers for handling of residuals. - ! This is correct because this routine is only called at levels >=2. - ! - p%base_a => p%ac - p%base_desc => p%desc_ac - end if + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by mld_aggrmap_bld and applying the aggregation + ! algorithm specified by p%iprcparm(mld_aggr_kind_) + ! + call mld_aggrmat_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_asb') goto 9999 end if - + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + p%base_a => p%ac + p%base_desc => p%desc_ac + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_dprecinit.F90 b/mlprec/impl/mld_dprecinit.F90 index c421d04d..3276c9e7 100644 --- a/mlprec/impl/mld_dprecinit.F90 +++ b/mlprec/impl/mld_dprecinit.F90 @@ -171,7 +171,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev) nlev_ = max(1,nlev) p%n_prec_levs = nlev_ else - nlev_ = p%max_prec_levs + nlev_ = 3 p%n_prec_levs = -ione end if ilev_ = 1 diff --git a/mlprec/impl/mld_s_dec_map_bld.f90 b/mlprec/impl/mld_s_dec_map_bld.f90 index 10be26e0..afd107fa 100644 --- a/mlprec/impl/mld_s_dec_map_bld.f90 +++ b/mlprec/impl/mld_s_dec_map_bld.f90 @@ -54,12 +54,12 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! Local variables integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& - & ideg(:), idxs(:) + & ideg(:), idxs(:), tmpaggr(:) real(psb_spk_), allocatable :: val(:), diag(:) integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip type(psb_s_csr_sparse_mat) :: acsr real(psb_spk_) :: cpling, tcl - logical :: recovery, candidate + logical :: disjoint integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -138,20 +138,15 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if end if enddo - if (ip < 1) then - write(0,*) "Should at least contain the node itself ! " - cycle step1 - end if - candidate = .true. - do k=1, ip - candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) - end do - if (candidate) then - ! - ! If the whole strongly coupled neighborhood of I is - ! as yet unconnected, turn it into the next aggregate - ! + ! + ! If the whole strongly coupled neighborhood of I is + ! as yet unconnected, turn it into the next aggregate. + ! Same if ip==0 (in which case, neighborhood only + ! contains I even if it does not look from matrix) + ! + disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) + if (disjoint) then icnt = icnt + 1 naggr = naggr + 1 do k=1, ip @@ -161,6 +156,7 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if endif enddo step1 + if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),& & ' Check 1:',count(ilaggr == -(nr+1)) @@ -168,7 +164,8 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! ! Phase two: join the neighbours - ! + ! + tmpaggr = ilaggr step2: do ii=1,nr i = idxs(ii) @@ -189,7 +186,7 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) j = icol(k) if ((1<=j).and.(j<=nr)) then if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& - & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then + & .and. (tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then ip = k cpling = abs(val(k)) end if @@ -208,7 +205,7 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) step3: do ii=1,nr i = idxs(ii) - if (ilaggr(i) == -(nr+1)) then + if (ilaggr(i) < 0) then call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -216,10 +213,10 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if ! - ! Find the most strongly connected neighbour that is - ! already aggregated, if any, and join its aggregate + ! Find its strongly connected neighbourhood not + ! already aggregated, and make it into a new aggregate. ! - cpling = szero + cpling = dzero ip = 0 do k=1, nz j = icol(k) diff --git a/mlprec/impl/mld_s_hierarchy_bld.f90 b/mlprec/impl/mld_s_hierarchy_bld.f90 index 5216b314..3faf3f57 100644 --- a/mlprec/impl/mld_s_hierarchy_bld.f90 +++ b/mlprec/impl/mld_s_hierarchy_bld.f90 @@ -94,9 +94,13 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! Local Variables integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs - real(psb_spk_) :: mnaggratio - integer(psb_ipk_) :: ipv(mld_ifpsz_), val + integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize + real(psb_spk_) :: mnaggratio, sizeratio + class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_sml_parms) :: baseparms, medparms, coarseparms + integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) + type(psb_sspmat_type) :: op_prol + type(mld_s_onelev_type), allocatable :: tprecv(:) integer(psb_ipk_) :: int_err(5) character :: upd_ integer(psb_ipk_) :: debug_level, debug_unit @@ -191,10 +195,23 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) goto 9999 endif + ! + ! The strategy: + ! 1. The maximum number of levels should be already encoded in the + ! size of the array; + ! 2. If the user did not specify anything, then a default coarse size + ! is generated, and the number of levels is set to the maximum; + ! 3. If the number of levels has been specified, make sure it's capped + ! at the maximum; + ! 4. If the size of the array is different from target number of levels, + ! reallocate; + ! 5. Build the matrix hierarchy, stopping early if either the target + ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! threshold. + ! + + if (nplevs <= 0) then - ! - ! This should become the default strategy, we specify a target aggregation size. - ! if (casize <=0) then ! ! Default to the cubic root of the size at base level. @@ -204,15 +221,200 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) casize = max(casize,ione) casize = casize*40_psb_ipk_ end if - call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info) - else + nplevs = mxplevs + end if + + nplevs = max(itwo,min(nplevs,mxplevs)) + + 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 + + ! + ! First set desired number of levels + ! + if (iszv /= nplevs) then + allocate(tprecv(nplevs),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + tprecv(1)%parms = baseparms + allocate(tprecv(1)%sm,source=base_sm,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=2,nplevs-1 + tprecv(i)%parms = medparms + allocate(tprecv(i)%sm,source=med_sm,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + end do + tprecv(nplevs)%parms = coarseparms + allocate(tprecv(nplevs)%sm,source=coarse_sm,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,iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + iszv = size(p%precv) + end if + + ! + ! Finest level first; remember to fix base_a and base_desc + ! + p%precv(1)%base_a => a + p%precv(1)%base_desc => desc_a + newsz = 0 + array_build_loop: do i=2, iszv + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + 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 ! - ! Oldstyle with fixed number of levels. + if (info == psb_success_) call mld_aggrmap_bld(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Map build') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + + ! - nplevs = max(itwo,min(nplevs,mxplevs)) - call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info) + ! Check for early termination of aggregation loop. + ! + iaggsize = sum(nlaggr) + if (iaggsize <= casize) then + newsz = i + end if + + if (i>2) then + sizeratio = iaggsize + sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio + if (sizeratio < mnaggratio) then + if (sizeratio > 1) then + newsz = i + else + ! + ! We are not gaining + ! + newsz = newsz-1 + end if + end if + + if (all(nlaggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + 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 + end if + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) & + & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) + + if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Map build') + goto 9999 + endif + + if (newsz > 0) exit array_build_loop + end do array_build_loop + + if (newsz > 0) then + ! + ! We exited early from the build loop, need to fix + ! the size. + ! + allocate(tprecv(newsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=1,newsz + call p%precv(i)%move_alloc(tprecv(i),info) + end do + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + ! 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 + 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 end if - + + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) @@ -220,7 +422,7 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) endif iszv = size(p%precv) - + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Exiting with',iszv,' levels' diff --git a/mlprec/impl/mld_s_lev_aggrmap_bld.f90 b/mlprec/impl/mld_s_lev_aggrmap_bld.f90 new file mode 100644 index 00000000..fa4b78aa --- /dev/null +++ b/mlprec/impl/mld_s_lev_aggrmap_bld.f90 @@ -0,0 +1,148 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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_scoarse_bld.f90 +! +! Subroutine: mld_scoarse_bld +! Version: real +! +! This routine builds the matrix associated to the current level of the +! multilevel preconditioner from the matrix associated to the previous level, +! by using a smoothed aggregation technique (therefore, it also builds the +! prolongation and restriction operators mapping the current level to the +! previous one and vice versa). Then the routine builds the base preconditioner +! at the current level. +! The current level is regarded as the coarse one, while the previous as +! the fine one. This is in agreement with the fact that the routine is called, +! by mld_mlprec_bld, only on levels >=2. +! +! +! Arguments: +! a - type(psb_sspmat_type). +! The sparse matrix structure containing the local part of the +! fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_s_onelev_type), input/output. +! The 'one-level' data structure containing the local part +! of the base preconditioner to be built as well as +! information concerning the prolongator and its transpose. +! info - integer, output. +! Error code. +! +subroutine mld_s_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + + use psb_base_mod + use mld_s_inner_mod, mld_protect_name => mld_s_lev_aggrmap_bld + + implicit none + + ! Arguments + type(mld_s_onelev_type), intent(inout), target :: p + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_sspmat_type), intent(out) :: op_prol + integer(psb_ipk_), intent(out) :: info + + + ! Local variables + character(len=20) :: name + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nzl, ntaggr + integer(psb_ipk_) :: debug_level, debug_unit + + name='mld_s_lev_aggrmap_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ictxt = desc_a%get_context() + call psb_info(ictxt,me,np) + + call mld_check_def(p%parms%ml_type,'Multilevel type',& + & mld_mult_ml_,is_legal_ml_type) + call mld_check_def(p%parms%aggr_alg,'Aggregation',& + & mld_dec_aggr_,is_legal_ml_aggr_alg) + call mld_check_def(p%parms%aggr_ord,'Ordering',& + & mld_aggr_ord_nat_,is_legal_ml_aggr_ord) + call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs) + + select case(p%parms%aggr_alg) + case (mld_dec_aggr_, mld_sym_dec_aggr_) + + ! + ! Build a mapping between the row indices of the fine-level matrix + ! and the row indices of the coarse-level matrix, according to a decoupled + ! aggregation algorithm. This also defines a tentative prolongator from + ! the coarse to the fine level. + ! + call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& + & a,desc_a,ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') + goto 9999 + end if + + case (mld_bcmatch_aggr_) + write(0,*) 'Matching is not implemented yet ' + info = -1111 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) + goto 9999 + + case default + + info = -1 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) + goto 9999 + + end select + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_s_lev_aggrmap_bld diff --git a/mlprec/impl/mld_s_lev_aggrmat_asb.f90 b/mlprec/impl/mld_s_lev_aggrmat_asb.f90 new file mode 100644 index 00000000..0d746a94 --- /dev/null +++ b/mlprec/impl/mld_s_lev_aggrmat_asb.f90 @@ -0,0 +1,252 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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_scoarse_bld.f90 +! +! Subroutine: mld_scoarse_bld +! Version: real +! +! This routine builds the matrix associated to the current level of the +! multilevel preconditioner from the matrix associated to the previous level, +! by using a smoothed aggregation technique (therefore, it also builds the +! prolongation and restriction operators mapping the current level to the +! previous one and vice versa). Then the routine builds the base preconditioner +! at the current level. +! The current level is regarded as the coarse one, while the previous as +! the fine one. This is in agreement with the fact that the routine is called, +! by mld_mlprec_bld, only on levels >=2. +! +! +! Arguments: +! a - type(psb_sspmat_type). +! The sparse matrix structure containing the local part of the +! fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_s_onelev_type), input/output. +! The 'one-level' data structure containing the local part +! of the base preconditioner to be built as well as +! information concerning the prolongator and its transpose. +! info - integer, output. +! Error code. +! +subroutine mld_s_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + + use psb_base_mod + use mld_s_inner_mod, mld_protect_name => mld_s_lev_aggrmat_asb + + implicit none + + ! Arguments + type(mld_s_onelev_type), intent(inout), target :: p + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:) + type(psb_sspmat_type), intent(inout) :: op_prol + integer(psb_ipk_), intent(out) :: info + + + ! Local variables + character(len=20) :: name + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + type(psb_sspmat_type) :: ac, op_restr + type(psb_s_coo_sparse_mat) :: acoo, bcoo + type(psb_s_csr_sparse_mat) :: acsr1 + integer(psb_ipk_) :: nzl, ntaggr + integer(psb_ipk_) :: debug_level, debug_unit + + name='mld_scoarse_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ictxt = desc_a%get_context() + call psb_info(ictxt,me,np) + + call mld_check_def(p%parms%aggr_kind,'Smoother',& + & mld_smooth_prol_,is_legal_ml_aggr_kind) + call mld_check_def(p%parms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_legal_ml_coarse_mat) + call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',& + & mld_no_filter_mat_,is_legal_aggr_filter) + call mld_check_def(p%parms%smoother_pos,'smooth_pos',& + & mld_pre_smooth_,is_legal_ml_smooth_pos) + call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',& + & mld_eig_est_,is_legal_ml_aggr_omega_alg) + call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',& + & mld_max_norm_,is_legal_ml_aggr_eig) + call mld_check_def(p%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega) + + + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by mld_aggrmap_bld and applying the aggregation + ! algorithm specified by p%iprcparm(mld_aggr_kind_) + ! + call mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') + goto 9999 + end if + + + ! Common code refactored here. + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + call ac%mv_to(bcoo) + if (p%parms%clean_zeros) call bcoo%clean_zeros(info) + nzl = bcoo%get_nzeros() + + 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 + ! + ! Clip to local rows. + ! + call op_restr%set_nrows(p%desc_ac%get_local_rows()) + + 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + p%base_a => p%ac + p%base_desc => p%desc_ac + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_s_lev_aggrmat_asb diff --git a/mlprec/impl/mld_saggrmap_bld.f90 b/mlprec/impl/mld_saggrmap_bld.f90 index b46bb98a..5dfd1af5 100644 --- a/mlprec/impl/mld_saggrmap_bld.f90 +++ b/mlprec/impl/mld_saggrmap_bld.f90 @@ -79,7 +79,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) +subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmap_bld @@ -93,13 +93,14 @@ subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_sspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_), allocatable :: ils(:), neigh(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m,naggrm1, naggrp1, ntaggr type(psb_sspmat_type) :: atmp, atrans - logical :: recovery + type(psb_s_coo_sparse_mat) :: tmpcoo integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -151,6 +152,28 @@ subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) goto 9999 end if + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + 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 + + call tmpcoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + tmpcoo%val(i) = sone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_sorted() ! At this point this is in row-major + call op_prol%mv_from(tmpcoo) + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_saggrmat_asb.f90 b/mlprec/impl/mld_saggrmat_asb.f90 index c0fe4b22..36bcb4db 100644 --- a/mlprec/impl/mld_saggrmat_asb.f90 +++ b/mlprec/impl/mld_saggrmat_asb.f90 @@ -98,7 +98,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_saggrmat_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_asb @@ -109,11 +109,12 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_sml_parms), intent(inout) :: parms type(mld_s_onelev_type), intent(inout), target :: p + type(psb_sspmat_type), intent(inout) :: ac, op_prol,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables - 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(psb_ipk_) :: nzl,ntaggr, err_act @@ -165,116 +166,6 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - - - ntaggr = sum(nlaggr) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call ac%mv_to(bcoo) - if (p%parms%clean_zeros) call bcoo%clean_zeros(info) - nzl = bcoo%get_nzeros() - - 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 - ! - ! Clip to local rows. - ! - call op_restr%set_nrows(p%desc_ac%get_local_rows()) - - 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 3e715cd6..f91c8102 100644 --- a/mlprec/impl/mld_saggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_saggrmat_biz_asb.f90 @@ -89,7 +89,8 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_sspmat_type), intent(inout) :: op_prol + type(psb_sspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -128,19 +129,8 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - naggrm1 = sum(nlaggr(1:me)) - naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (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. ! @@ -157,17 +147,10 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr end if ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,naggr,ncol) - do i=1,nrow - tmpcoo%val(i) = sone - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(nrow) - call tmpcoo%set_dupl(psb_dupl_add_) - + call op_prol%mv_to(tmpcoo) call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + if (info /= psb_success_) goto 9999 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 e9e15e4a..3868d9c6 100644 --- a/mlprec/impl/mld_saggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 @@ -108,8 +108,9 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sml_parms), intent(inout) :: parms - type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(inout) :: op_prol + type(psb_sspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -167,14 +168,6 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re filter_mat = (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. ! @@ -209,20 +202,10 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - tmpcoo%val(i) = sone - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(ncol) - call tmpcoo%set_dupl(psb_dupl_add_) - call tmpcoo%set_asb() + call op_prol%mv_to(tmpcoo) call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') -!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') - if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_) if (info /= psb_success_) then @@ -276,7 +259,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re call am3%mv_to(acsr3) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = szero do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -454,7 +437,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re omp = omp/oden ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = szero do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) diff --git a/mlprec/impl/mld_saggrmat_nosmth_asb.f90 b/mlprec/impl/mld_saggrmat_nosmth_asb.f90 index 78608ea0..bbb8246f 100644 --- a/mlprec/impl/mld_saggrmat_nosmth_asb.f90 +++ b/mlprec/impl/mld_saggrmat_nosmth_asb.f90 @@ -92,7 +92,8 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_sspmat_type), intent(inout) :: op_prol + type(psb_sspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -124,34 +125,12 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ntaggr = sum(nlaggr) naggrm1=sum(nlaggr(1:me)) - 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 - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,nrow - acoo%val(i) = sone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - - 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(acoo) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call op_prol%transp(op_restr) - + if (info /= psb_success_) goto 9999 + call op_prol%transp(op_restr) + call a%cp_to(ac_coo) nzt = ac_coo%get_nzeros() diff --git a/mlprec/impl/mld_saggrmat_smth_asb.f90 b/mlprec/impl/mld_saggrmat_smth_asb.f90 index 1d00dda1..03eb2155 100644 --- a/mlprec/impl/mld_saggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_saggrmat_smth_asb.f90 @@ -104,7 +104,8 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_sspmat_type), intent(inout) :: op_prol + type(psb_sspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -147,14 +148,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest naggrp1 = sum(nlaggr(1:me+1)) filter_mat = (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. ! @@ -172,17 +166,10 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest end if ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - tmpcoo%val(i) = sone - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(ncol) - call tmpcoo%set_dupl(psb_dupl_add_) - call tmpcoo%set_sorted() ! At this point this is in row-major + call op_prol%mv_to(tmpcoo) call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + if (info /= psb_success_) goto 9999 if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_z_dec_map_bld.f90 b/mlprec/impl/mld_z_dec_map_bld.f90 index 876b8a7e..dffb3402 100644 --- a/mlprec/impl/mld_z_dec_map_bld.f90 +++ b/mlprec/impl/mld_z_dec_map_bld.f90 @@ -54,12 +54,12 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! Local variables integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),& - & ideg(:), idxs(:) + & ideg(:), idxs(:), tmpaggr(:) complex(psb_dpk_), allocatable :: val(:), diag(:) integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz, ilg, ii, ip type(psb_z_csr_sparse_mat) :: acsr real(psb_dpk_) :: cpling, tcl - logical :: recovery, candidate + logical :: disjoint integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -138,20 +138,15 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if end if enddo - if (ip < 1) then - write(0,*) "Should at least contain the node itself ! " - cycle step1 - end if - candidate = .true. - do k=1, ip - candidate = candidate .and. (ilaggr(icol(k)) == -(nr+1)) - end do - if (candidate) then - ! - ! If the whole strongly coupled neighborhood of I is - ! as yet unconnected, turn it into the next aggregate - ! + ! + ! If the whole strongly coupled neighborhood of I is + ! as yet unconnected, turn it into the next aggregate. + ! Same if ip==0 (in which case, neighborhood only + ! contains I even if it does not look from matrix) + ! + disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) + if (disjoint) then icnt = icnt + 1 naggr = naggr + 1 do k=1, ip @@ -161,6 +156,7 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) end if endif enddo step1 + if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),& & ' Check 1:',count(ilaggr == -(nr+1)) @@ -168,7 +164,8 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! ! Phase two: join the neighbours - ! + ! + tmpaggr = ilaggr step2: do ii=1,nr i = idxs(ii) @@ -189,7 +186,7 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) j = icol(k) if ((1<=j).and.(j<=nr)) then if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j))))& - & .and. (ilaggr(j) > 0).and. (abs(val(k)) > cpling)) then + & .and. (tmpaggr(j) > 0).and. (abs(val(k)) > cpling)) then ip = k cpling = abs(val(k)) end if @@ -208,7 +205,7 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) step3: do ii=1,nr i = idxs(ii) - if (ilaggr(i) == -(nr+1)) then + if (ilaggr(i) < 0) then call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -216,8 +213,8 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) goto 9999 end if ! - ! Find the most strongly connected neighbour that is - ! already aggregated, if any, and join its aggregate + ! Find its strongly connected neighbourhood not + ! already aggregated, and make it into a new aggregate. ! cpling = dzero ip = 0 diff --git a/mlprec/impl/mld_z_hierarchy_bld.f90 b/mlprec/impl/mld_z_hierarchy_bld.f90 index ab14a40a..47689ee5 100644 --- a/mlprec/impl/mld_z_hierarchy_bld.f90 +++ b/mlprec/impl/mld_z_hierarchy_bld.f90 @@ -94,9 +94,13 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! Local Variables integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs - real(psb_dpk_) :: mnaggratio - integer(psb_ipk_) :: ipv(mld_ifpsz_), val + integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize + real(psb_dpk_) :: mnaggratio, sizeratio + class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_dml_parms) :: baseparms, medparms, coarseparms + integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) + type(psb_zspmat_type) :: op_prol + type(mld_z_onelev_type), allocatable :: tprecv(:) integer(psb_ipk_) :: int_err(5) character :: upd_ integer(psb_ipk_) :: debug_level, debug_unit @@ -191,10 +195,23 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) goto 9999 endif + ! + ! The strategy: + ! 1. The maximum number of levels should be already encoded in the + ! size of the array; + ! 2. If the user did not specify anything, then a default coarse size + ! is generated, and the number of levels is set to the maximum; + ! 3. If the number of levels has been specified, make sure it's capped + ! at the maximum; + ! 4. If the size of the array is different from target number of levels, + ! reallocate; + ! 5. Build the matrix hierarchy, stopping early if either the target + ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! threshold. + ! + + if (nplevs <= 0) then - ! - ! This should become the default strategy, we specify a target aggregation size. - ! if (casize <=0) then ! ! Default to the cubic root of the size at base level. @@ -204,15 +221,200 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) casize = max(casize,ione) casize = casize*40_psb_ipk_ end if - call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info) - else + nplevs = mxplevs + end if + + nplevs = max(itwo,min(nplevs,mxplevs)) + + 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 + + ! + ! First set desired number of levels + ! + if (iszv /= nplevs) then + allocate(tprecv(nplevs),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + tprecv(1)%parms = baseparms + allocate(tprecv(1)%sm,source=base_sm,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=2,nplevs-1 + tprecv(i)%parms = medparms + allocate(tprecv(i)%sm,source=med_sm,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + end do + tprecv(nplevs)%parms = coarseparms + allocate(tprecv(nplevs)%sm,source=coarse_sm,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,iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + iszv = size(p%precv) + end if + + ! + ! Finest level first; remember to fix base_a and base_desc + ! + p%precv(1)%base_a => a + p%precv(1)%base_desc => desc_a + newsz = 0 + array_build_loop: do i=2, iszv + ! + ! Check on the iprcparm contents: they should be the same + ! on all processes. + ! + 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 ! - ! Oldstyle with fixed number of levels. + if (info == psb_success_) call mld_aggrmap_bld(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Map build') + goto 9999 + endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Return from ',i,' call to mlprcbld ',info + + ! - nplevs = max(itwo,min(nplevs,mxplevs)) - call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info) + ! Check for early termination of aggregation loop. + ! + iaggsize = sum(nlaggr) + if (iaggsize <= casize) then + newsz = i + end if + + if (i>2) then + sizeratio = iaggsize + sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio + if (sizeratio < mnaggratio) then + if (sizeratio > 1) then + newsz = i + else + ! + ! We are not gaining + ! + newsz = newsz-1 + end if + end if + + if (all(nlaggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + 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 + end if + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) & + & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) + + if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Map build') + goto 9999 + endif + + if (newsz > 0) exit array_build_loop + end do array_build_loop + + if (newsz > 0) then + ! + ! We exited early from the build loop, need to fix + ! the size. + ! + allocate(tprecv(newsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') + goto 9999 + endif + do i=1,newsz + call p%precv(i)%move_alloc(tprecv(i),info) + end do + do i=newsz+1, iszv + call p%precv(i)%free(info) + end do + call move_alloc(tprecv,p%precv) + ! 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 + 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 end if - + + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) @@ -220,7 +422,7 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) endif iszv = size(p%precv) - + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Exiting with',iszv,' levels' diff --git a/mlprec/impl/mld_z_lev_aggrmap_bld.f90 b/mlprec/impl/mld_z_lev_aggrmap_bld.f90 new file mode 100644 index 00000000..52892fde --- /dev/null +++ b/mlprec/impl/mld_z_lev_aggrmap_bld.f90 @@ -0,0 +1,148 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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_zcoarse_bld.f90 +! +! Subroutine: mld_zcoarse_bld +! Version: real +! +! This routine builds the matrix associated to the current level of the +! multilevel preconditioner from the matrix associated to the previous level, +! by using a smoothed aggregation technique (therefore, it also builds the +! prolongation and restriction operators mapping the current level to the +! previous one and vice versa). Then the routine builds the base preconditioner +! at the current level. +! The current level is regarded as the coarse one, while the previous as +! the fine one. This is in agreement with the fact that the routine is called, +! by mld_mlprec_bld, only on levels >=2. +! +! +! Arguments: +! a - type(psb_zspmat_type). +! The sparse matrix structure containing the local part of the +! fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_z_onelev_type), input/output. +! The 'one-level' data structure containing the local part +! of the base preconditioner to be built as well as +! information concerning the prolongator and its transpose. +! info - integer, output. +! Error code. +! +subroutine mld_z_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + + use psb_base_mod + use mld_z_inner_mod, mld_protect_name => mld_z_lev_aggrmap_bld + + implicit none + + ! Arguments + type(mld_z_onelev_type), intent(inout), target :: p + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_zspmat_type), intent(out) :: op_prol + integer(psb_ipk_), intent(out) :: info + + + ! Local variables + character(len=20) :: name + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nzl, ntaggr + integer(psb_ipk_) :: debug_level, debug_unit + + name='mld_z_lev_aggrmap_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ictxt = desc_a%get_context() + call psb_info(ictxt,me,np) + + call mld_check_def(p%parms%ml_type,'Multilevel type',& + & mld_mult_ml_,is_legal_ml_type) + call mld_check_def(p%parms%aggr_alg,'Aggregation',& + & mld_dec_aggr_,is_legal_ml_aggr_alg) + call mld_check_def(p%parms%aggr_ord,'Ordering',& + & mld_aggr_ord_nat_,is_legal_ml_aggr_ord) + call mld_check_def(p%parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs) + + select case(p%parms%aggr_alg) + case (mld_dec_aggr_, mld_sym_dec_aggr_) + + ! + ! Build a mapping between the row indices of the fine-level matrix + ! and the row indices of the coarse-level matrix, according to a decoupled + ! aggregation algorithm. This also defines a tentative prolongator from + ! the coarse to the fine level. + ! + call mld_aggrmap_bld(p%parms%aggr_alg,p%parms%aggr_ord,p%parms%aggr_thresh,& + & a,desc_a,ilaggr,nlaggr,op_prol,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') + goto 9999 + end if + + case (mld_bcmatch_aggr_) + write(0,*) 'Matching is not implemented yet ' + info = -1111 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) + goto 9999 + + case default + + info = -1 + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ione,p%parms%aggr_alg,izero,izero,izero/)) + goto 9999 + + end select + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_z_lev_aggrmap_bld diff --git a/mlprec/impl/mld_z_lev_aggrmat_asb.f90 b/mlprec/impl/mld_z_lev_aggrmat_asb.f90 new file mode 100644 index 00000000..6101fbed --- /dev/null +++ b/mlprec/impl/mld_z_lev_aggrmat_asb.f90 @@ -0,0 +1,252 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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_zcoarse_bld.f90 +! +! Subroutine: mld_zcoarse_bld +! Version: real +! +! This routine builds the matrix associated to the current level of the +! multilevel preconditioner from the matrix associated to the previous level, +! by using a smoothed aggregation technique (therefore, it also builds the +! prolongation and restriction operators mapping the current level to the +! previous one and vice versa). Then the routine builds the base preconditioner +! at the current level. +! The current level is regarded as the coarse one, while the previous as +! the fine one. This is in agreement with the fact that the routine is called, +! by mld_mlprec_bld, only on levels >=2. +! +! +! Arguments: +! a - type(psb_zspmat_type). +! The sparse matrix structure containing the local part of the +! fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_z_onelev_type), input/output. +! The 'one-level' data structure containing the local part +! of the base preconditioner to be built as well as +! information concerning the prolongator and its transpose. +! info - integer, output. +! Error code. +! +subroutine mld_z_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + + use psb_base_mod + use mld_z_inner_mod, mld_protect_name => mld_z_lev_aggrmat_asb + + implicit none + + ! Arguments + type(mld_z_onelev_type), intent(inout), target :: p + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:) + type(psb_zspmat_type), intent(inout) :: op_prol + integer(psb_ipk_), intent(out) :: info + + + ! Local variables + character(len=20) :: name + integer(psb_mpik_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + type(psb_zspmat_type) :: ac, op_restr + type(psb_z_coo_sparse_mat) :: acoo, bcoo + type(psb_z_csr_sparse_mat) :: acsr1 + integer(psb_ipk_) :: nzl, ntaggr + integer(psb_ipk_) :: debug_level, debug_unit + + name='mld_zcoarse_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ictxt = desc_a%get_context() + call psb_info(ictxt,me,np) + + call mld_check_def(p%parms%aggr_kind,'Smoother',& + & mld_smooth_prol_,is_legal_ml_aggr_kind) + call mld_check_def(p%parms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_legal_ml_coarse_mat) + call mld_check_def(p%parms%aggr_filter,'Use filtered matrix',& + & mld_no_filter_mat_,is_legal_aggr_filter) + call mld_check_def(p%parms%smoother_pos,'smooth_pos',& + & mld_pre_smooth_,is_legal_ml_smooth_pos) + call mld_check_def(p%parms%aggr_omega_alg,'Omega Alg.',& + & mld_eig_est_,is_legal_ml_aggr_omega_alg) + call mld_check_def(p%parms%aggr_eig,'Eigenvalue estimate',& + & mld_max_norm_,is_legal_ml_aggr_eig) + call mld_check_def(p%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) + + + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by mld_aggrmap_bld and applying the aggregation + ! algorithm specified by p%iprcparm(mld_aggr_kind_) + ! + call mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p%parms,ac,op_prol,op_restr,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') + goto 9999 + end if + + + ! Common code refactored here. + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + call ac%mv_to(bcoo) + if (p%parms%clean_zeros) call bcoo%clean_zeros(info) + nzl = bcoo%get_nzeros() + + 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 + ! + ! Clip to local rows. + ! + call op_restr%set_nrows(p%desc_ac%get_local_rows()) + + 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + p%base_a => p%ac + p%base_desc => p%desc_ac + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine mld_z_lev_aggrmat_asb diff --git a/mlprec/impl/mld_zaggrmap_bld.f90 b/mlprec/impl/mld_zaggrmap_bld.f90 index 2058fd66..9af55340 100644 --- a/mlprec/impl/mld_zaggrmap_bld.f90 +++ b/mlprec/impl/mld_zaggrmap_bld.f90 @@ -79,7 +79,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) +subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmap_bld @@ -93,13 +93,14 @@ subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_zspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_), allocatable :: ils(:), neigh(:) - integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m + integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m,naggrm1, naggrp1, ntaggr type(psb_zspmat_type) :: atmp, atrans - logical :: recovery + type(psb_z_coo_sparse_mat) :: tmpcoo integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: nrow, ncol, n_ne @@ -151,6 +152,28 @@ subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) goto 9999 end if + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + 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 + + call tmpcoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + tmpcoo%val(i) = zone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_sorted() ! At this point this is in row-major + call op_prol%mv_from(tmpcoo) + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_zaggrmat_asb.f90 b/mlprec/impl/mld_zaggrmat_asb.f90 index c6ebe19a..f7a4dbe7 100644 --- a/mlprec/impl/mld_zaggrmat_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_asb.f90 @@ -98,7 +98,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_zaggrmat_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_asb @@ -109,11 +109,12 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_dml_parms), intent(inout) :: parms type(mld_z_onelev_type), intent(inout), target :: p + type(psb_zspmat_type), intent(inout) :: ac, op_prol,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables - 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(psb_ipk_) :: nzl,ntaggr, err_act @@ -165,116 +166,6 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - - - ntaggr = sum(nlaggr) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call ac%mv_to(bcoo) - if (p%parms%clean_zeros) call bcoo%clean_zeros(info) - nzl = bcoo%get_nzeros() - - 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 - ! - ! Clip to local rows. - ! - call op_restr%set_nrows(p%desc_ac%get_local_rows()) - - 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_).and.p%parms%clean_zeros) call ac%clean_zeros(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 64bcf643..96b3f49f 100644 --- a/mlprec/impl/mld_zaggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_biz_asb.f90 @@ -89,7 +89,8 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_zspmat_type), intent(inout) :: op_prol + type(psb_zspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -128,19 +129,8 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - naggrm1 = sum(nlaggr(1:me)) - naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (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. ! @@ -157,17 +147,10 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr end if ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,naggr,ncol) - do i=1,nrow - tmpcoo%val(i) = zone - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(nrow) - call tmpcoo%set_dupl(psb_dupl_add_) - + call op_prol%mv_to(tmpcoo) call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + if (info /= psb_success_) goto 9999 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 ba0238e0..80143f4d 100644 --- a/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 @@ -108,8 +108,9 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_dml_parms), intent(inout) :: parms - type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(inout) :: op_prol + type(psb_zspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -167,14 +168,6 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re filter_mat = (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. ! @@ -209,20 +202,10 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - tmpcoo%val(i) = zone - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(ncol) - call tmpcoo%set_dupl(psb_dupl_add_) - call tmpcoo%set_asb() + call op_prol%mv_to(tmpcoo) call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') -!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') - if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_) if (info /= psb_success_) then @@ -276,7 +259,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re call am3%mv_to(acsr3) ! Compute omega_int - ommx = cmplx(dzero,dzero) + ommx = zzero do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -454,7 +437,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re omp = omp/oden ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! Compute omega_int - ommx = cmplx(dzero,dzero) + ommx = zzero do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) diff --git a/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 b/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 index 580b4e73..4d3960bb 100644 --- a/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 @@ -92,7 +92,8 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_zspmat_type), intent(inout) :: op_prol + type(psb_zspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -124,34 +125,12 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re ntaggr = sum(nlaggr) naggrm1=sum(nlaggr(1:me)) - 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 - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,nrow - acoo%val(i) = zone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - - 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(acoo) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call op_prol%transp(op_restr) - + if (info /= psb_success_) goto 9999 + call op_prol%transp(op_restr) + call a%cp_to(ac_coo) nzt = ac_coo%get_nzeros() diff --git a/mlprec/impl/mld_zaggrmat_smth_asb.f90 b/mlprec/impl/mld_zaggrmat_smth_asb.f90 index 794210b5..8e85e14e 100644 --- a/mlprec/impl/mld_zaggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_smth_asb.f90 @@ -104,7 +104,8 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr + type(psb_zspmat_type), intent(inout) :: op_prol + type(psb_zspmat_type), intent(out) :: ac,op_restr integer(psb_ipk_), intent(out) :: info ! Local variables @@ -147,14 +148,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest naggrp1 = sum(nlaggr(1:me+1)) filter_mat = (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. ! @@ -172,17 +166,10 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest end if ! 1. Allocate Ptilde in sparse matrix form - call tmpcoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - tmpcoo%val(i) = zone - tmpcoo%ia(i) = i - tmpcoo%ja(i) = ilaggr(i) - end do - call tmpcoo%set_nzeros(ncol) - call tmpcoo%set_dupl(psb_dupl_add_) - call tmpcoo%set_sorted() ! At this point this is in row-major + call op_prol%mv_to(tmpcoo) call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + if (info /= psb_success_) goto 9999 if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 9da1ce64..6b349f97 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -124,11 +124,12 @@ module mld_c_inner_mod end interface mld_bld_mlhier_aggsize interface mld_bld_mlhier_array - subroutine mld_c_bld_mlhier_array(nplevs,a,desc_a,precv,info) + subroutine mld_c_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type use mld_c_prec_type, only : mld_c_onelev_type implicit none - integer(psb_ipk_), intent(inout) :: nplevs + integer(psb_ipk_), intent(inout) :: nplevs, casize + real(psb_spk_) :: mnaggratio type(psb_cspmat_type),intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_c_onelev_type), allocatable, target, intent(inout) :: precv(:) @@ -137,6 +138,17 @@ module mld_c_inner_mod end interface mld_bld_mlhier_array interface mld_aggrmap_bld + subroutine mld_c_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_ + use mld_c_prec_type, only : mld_c_onelev_type + implicit none + type(mld_c_onelev_type), intent(inout), target :: p + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: ilaggr(:),nlaggr(:) + type(psb_cspmat_type), intent(out) :: op_prol + integer(psb_ipk_), intent(out) :: info + end subroutine mld_c_lev_aggrmap_bld subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_ implicit none @@ -165,6 +177,20 @@ module mld_c_inner_mod end interface mld_dec_map_bld + interface mld_lev_mat_asb + subroutine mld_c_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_ + use mld_c_prec_type, only : mld_c_onelev_type + implicit none + type(mld_c_onelev_type), intent(inout), target :: p + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:) + type(psb_cspmat_type), intent(inout) :: op_prol + integer(psb_ipk_), intent(out) :: info + end subroutine mld_c_lev_aggrmat_asb + end interface mld_lev_mat_asb + 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_, psb_ipk_ diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index 27599ffe..309119ce 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -125,11 +125,11 @@ module mld_d_inner_mod interface mld_bld_mlhier_array subroutine mld_d_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) - use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type, psb_dpk_ + use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type use mld_d_prec_type, only : mld_d_onelev_type implicit none - integer(psb_ipk_), intent(inout) :: nplevs, casize - real(psb_dpk_) :: mnaggratio + integer(psb_ipk_), intent(inout) :: nplevs, casize + real(psb_dpk_) :: mnaggratio type(psb_dspmat_type),intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_d_onelev_type), allocatable, target, intent(inout) :: precv(:) @@ -145,11 +145,11 @@ module mld_d_inner_mod type(mld_d_onelev_type), intent(inout), target :: p type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + integer(psb_ipk_), intent(out) :: ilaggr(:),nlaggr(:) type(psb_dspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_d_lev_aggrmap_bld - subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) + subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ implicit none integer(psb_ipk_), intent(in) :: iorder @@ -158,7 +158,6 @@ module mld_d_inner_mod type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) - type(psb_dspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_daggrmap_bld end interface mld_aggrmap_bld @@ -192,6 +191,20 @@ module mld_d_inner_mod end subroutine mld_d_lev_aggrmat_asb end interface mld_lev_mat_asb + 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_, psb_ipk_ + use mld_d_prec_type, only : mld_d_onelev_type + implicit none + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_d_onelev_type), intent(inout), target :: p + integer(psb_ipk_), intent(out) :: info + end subroutine mld_daggrmat_asb + end interface mld_aggrmat_asb + + abstract interface subroutine mld_daggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) @@ -202,8 +215,7 @@ module mld_d_inner_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(inout) :: op_prol - type(psb_dspmat_type), intent(out) :: ac,op_restr + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr integer(psb_ipk_), intent(out) :: info end subroutine mld_daggrmat_var_asb end interface @@ -211,7 +223,7 @@ module mld_d_inner_mod procedure(mld_daggrmat_var_asb) :: mld_daggrmat_nosmth_asb, & & mld_daggrmat_smth_asb, mld_daggrmat_minnrg_asb, & - & mld_daggrmat_biz_asb, mld_daggrmat_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 ed6dfa77..3adf013d 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -124,11 +124,12 @@ module mld_s_inner_mod end interface mld_bld_mlhier_aggsize interface mld_bld_mlhier_array - subroutine mld_s_bld_mlhier_array(nplevs,a,desc_a,precv,info) + subroutine mld_s_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type use mld_s_prec_type, only : mld_s_onelev_type implicit none - integer(psb_ipk_), intent(inout) :: nplevs + integer(psb_ipk_), intent(inout) :: nplevs, casize + real(psb_spk_) :: mnaggratio type(psb_sspmat_type),intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_s_onelev_type), allocatable, target, intent(inout) :: precv(:) @@ -137,6 +138,17 @@ module mld_s_inner_mod end interface mld_bld_mlhier_array interface mld_aggrmap_bld + subroutine mld_s_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_ + use mld_s_prec_type, only : mld_s_onelev_type + implicit none + type(mld_s_onelev_type), intent(inout), target :: p + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: ilaggr(:),nlaggr(:) + type(psb_sspmat_type), intent(out) :: op_prol + integer(psb_ipk_), intent(out) :: info + end subroutine mld_s_lev_aggrmap_bld subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_ implicit none @@ -165,6 +177,20 @@ module mld_s_inner_mod end interface mld_dec_map_bld + interface mld_lev_mat_asb + subroutine mld_s_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_ + use mld_s_prec_type, only : mld_s_onelev_type + implicit none + type(mld_s_onelev_type), intent(inout), target :: p + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:) + type(psb_sspmat_type), intent(inout) :: op_prol + integer(psb_ipk_), intent(out) :: info + end subroutine mld_s_lev_aggrmat_asb + end interface mld_lev_mat_asb + 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_, psb_ipk_ diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index 2af263d8..b1f811ce 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -124,11 +124,12 @@ module mld_z_inner_mod end interface mld_bld_mlhier_aggsize interface mld_bld_mlhier_array - subroutine mld_z_bld_mlhier_array(nplevs,a,desc_a,precv,info) + subroutine mld_z_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type use mld_z_prec_type, only : mld_z_onelev_type implicit none - integer(psb_ipk_), intent(inout) :: nplevs + integer(psb_ipk_), intent(inout) :: nplevs, casize + real(psb_dpk_) :: mnaggratio type(psb_zspmat_type),intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_z_onelev_type), allocatable, target, intent(inout) :: precv(:) @@ -137,6 +138,17 @@ module mld_z_inner_mod end interface mld_bld_mlhier_array interface mld_aggrmap_bld + subroutine mld_z_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ + use mld_z_prec_type, only : mld_z_onelev_type + implicit none + type(mld_z_onelev_type), intent(inout), target :: p + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: ilaggr(:),nlaggr(:) + type(psb_zspmat_type), intent(out) :: op_prol + integer(psb_ipk_), intent(out) :: info + end subroutine mld_z_lev_aggrmap_bld subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ implicit none @@ -165,6 +177,20 @@ module mld_z_inner_mod end interface mld_dec_map_bld + interface mld_lev_mat_asb + subroutine mld_z_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info) + use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ + use mld_z_prec_type, only : mld_z_onelev_type + implicit none + type(mld_z_onelev_type), intent(inout), target :: p + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:) + type(psb_zspmat_type), intent(inout) :: op_prol + integer(psb_ipk_), intent(out) :: info + end subroutine mld_z_lev_aggrmat_asb + end interface mld_lev_mat_asb + 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_, psb_ipk_ From 443e36bf334360265f406837cc95c30a43630bca Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 30 Sep 2016 19:27:55 +0000 Subject: [PATCH 14/21] mld2p4-extaggr: mlprec/impl/mld_caggrmat_asb.f90 mlprec/impl/mld_daggrmat_asb.f90 mlprec/impl/mld_saggrmat_asb.f90 mlprec/impl/mld_zaggrmat_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 Fix import and interface. --- mlprec/impl/mld_caggrmat_asb.f90 | 1 - mlprec/impl/mld_daggrmat_asb.f90 | 1 - mlprec/impl/mld_saggrmat_asb.f90 | 1 - mlprec/impl/mld_zaggrmat_asb.f90 | 1 - mlprec/mld_c_inner_mod.f90 | 9 +++++---- mlprec/mld_d_inner_mod.f90 | 9 +++++---- mlprec/mld_s_inner_mod.f90 | 9 +++++---- mlprec/mld_z_inner_mod.f90 | 9 +++++---- 8 files changed, 20 insertions(+), 20 deletions(-) diff --git a/mlprec/impl/mld_caggrmat_asb.f90 b/mlprec/impl/mld_caggrmat_asb.f90 index 1cef24ee..39f9cf11 100644 --- a/mlprec/impl/mld_caggrmat_asb.f90 +++ b/mlprec/impl/mld_caggrmat_asb.f90 @@ -110,7 +110,6 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(mld_c_onelev_type), intent(inout), target :: p type(psb_cspmat_type), intent(inout) :: ac, op_prol,op_restr integer(psb_ipk_), intent(out) :: info diff --git a/mlprec/impl/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 index 2c7ab573..f8422b0f 100644 --- a/mlprec/impl/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -110,7 +110,6 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(mld_d_onelev_type), intent(inout), target :: p type(psb_dspmat_type), intent(inout) :: ac, op_prol,op_restr integer(psb_ipk_), intent(out) :: info diff --git a/mlprec/impl/mld_saggrmat_asb.f90 b/mlprec/impl/mld_saggrmat_asb.f90 index 36bcb4db..bbee5a6f 100644 --- a/mlprec/impl/mld_saggrmat_asb.f90 +++ b/mlprec/impl/mld_saggrmat_asb.f90 @@ -110,7 +110,6 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_sml_parms), intent(inout) :: parms - type(mld_s_onelev_type), intent(inout), target :: p type(psb_sspmat_type), intent(inout) :: ac, op_prol,op_restr integer(psb_ipk_), intent(out) :: info diff --git a/mlprec/impl/mld_zaggrmat_asb.f90 b/mlprec/impl/mld_zaggrmat_asb.f90 index f7a4dbe7..7a5cfeff 100644 --- a/mlprec/impl/mld_zaggrmat_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_asb.f90 @@ -110,7 +110,6 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) type(mld_dml_parms), intent(inout) :: parms - type(mld_z_onelev_type), intent(inout), target :: p type(psb_zspmat_type), intent(inout) :: ac, op_prol,op_restr integer(psb_ipk_), intent(out) :: info diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 6b349f97..8073b94c 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -125,7 +125,7 @@ module mld_c_inner_mod interface mld_bld_mlhier_array subroutine mld_c_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) - use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type + use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type, psb_spk_ use mld_c_prec_type, only : mld_c_onelev_type implicit none integer(psb_ipk_), intent(inout) :: nplevs, casize @@ -192,14 +192,15 @@ module mld_c_inner_mod end interface mld_lev_mat_asb interface mld_aggrmat_asb - subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + subroutine mld_caggrmat_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_, psb_ipk_ - use mld_c_prec_type, only : mld_c_onelev_type + use mld_c_prec_type, only : mld_sml_parms implicit none type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), 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(psb_ipk_), intent(out) :: info end subroutine mld_caggrmat_asb end interface mld_aggrmat_asb diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index 309119ce..19eab0ca 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -125,7 +125,7 @@ module mld_d_inner_mod interface mld_bld_mlhier_array subroutine mld_d_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) - use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type + use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type, psb_dpk_ use mld_d_prec_type, only : mld_d_onelev_type implicit none integer(psb_ipk_), intent(inout) :: nplevs, casize @@ -192,14 +192,15 @@ module mld_d_inner_mod end interface mld_lev_mat_asb interface mld_aggrmat_asb - subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + subroutine mld_daggrmat_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_, psb_ipk_ - use mld_d_prec_type, only : mld_d_onelev_type + use mld_d_prec_type, only : mld_dml_parms implicit none type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), 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(psb_ipk_), intent(out) :: info end subroutine mld_daggrmat_asb end interface mld_aggrmat_asb diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index 3adf013d..631a1a1f 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -125,7 +125,7 @@ module mld_s_inner_mod interface mld_bld_mlhier_array subroutine mld_s_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) - use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type + use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type, psb_spk_ use mld_s_prec_type, only : mld_s_onelev_type implicit none integer(psb_ipk_), intent(inout) :: nplevs, casize @@ -192,14 +192,15 @@ module mld_s_inner_mod end interface mld_lev_mat_asb interface mld_aggrmat_asb - subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + subroutine mld_saggrmat_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_, psb_ipk_ - use mld_s_prec_type, only : mld_s_onelev_type + use mld_s_prec_type, only : mld_sml_parms implicit none type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), 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(psb_ipk_), intent(out) :: info end subroutine mld_saggrmat_asb end interface mld_aggrmat_asb diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index b1f811ce..bf5d416a 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -125,7 +125,7 @@ module mld_z_inner_mod interface mld_bld_mlhier_array subroutine mld_z_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info) - use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type + use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type, psb_dpk_ use mld_z_prec_type, only : mld_z_onelev_type implicit none integer(psb_ipk_), intent(inout) :: nplevs, casize @@ -192,14 +192,15 @@ module mld_z_inner_mod end interface mld_lev_mat_asb interface mld_aggrmat_asb - subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + subroutine mld_zaggrmat_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_, psb_ipk_ - use mld_z_prec_type, only : mld_z_onelev_type + use mld_z_prec_type, only : mld_dml_parms implicit none type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), 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(psb_ipk_), intent(out) :: info end subroutine mld_zaggrmat_asb end interface mld_aggrmat_asb From 0da9c937f05f62a215110199abdf7285e008c1f1 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 30 Sep 2016 19:29:19 +0000 Subject: [PATCH 15/21] *** empty log message *** --- mlprec/impl/Makefile | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index 6b7c2bf5..84b4bfd1 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -22,25 +22,25 @@ MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS) MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o -DINNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_d_bld_mlhier_aggsize.o mld_d_bld_mlhier_array.o \ +DINNEROBJS= mld_dmlprec_bld.o mld_d_bld_mlhier_aggsize.o mld_d_bld_mlhier_array.o \ mld_d_ml_prec_bld.o mld_d_hierarchy_bld.o \ mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \ mld_d_dec_map_bld.o mld_dmlprec_aply.o mld_daggrmat_asb.o \ $(DMPFOBJS) mld_d_extprol_bld.o mld_d_lev_aggrmap_bld.o mld_d_lev_aggrmat_asb.o -SINNEROBJS= mld_scoarse_bld.o mld_smlprec_bld.o mld_s_bld_mlhier_aggsize.o mld_s_bld_mlhier_array.o \ +SINNEROBJS= mld_smlprec_bld.o mld_s_bld_mlhier_aggsize.o mld_s_bld_mlhier_array.o \ mld_s_ml_prec_bld.o mld_s_hierarchy_bld.o \ mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o mld_saggrmap_bld.o \ mld_s_dec_map_bld.o mld_smlprec_aply.o mld_saggrmat_asb.o \ $(SMPFOBJS) mld_s_extprol_bld.o mld_s_lev_aggrmap_bld.o mld_s_lev_aggrmat_asb.o -ZINNEROBJS= mld_zcoarse_bld.o mld_zmlprec_bld.o mld_z_bld_mlhier_aggsize.o mld_z_bld_mlhier_array.o \ +ZINNEROBJS= mld_zmlprec_bld.o mld_z_bld_mlhier_aggsize.o mld_z_bld_mlhier_array.o \ mld_z_ml_prec_bld.o mld_z_hierarchy_bld.o \ mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \ mld_z_dec_map_bld.o mld_zmlprec_aply.o mld_zaggrmat_asb.o \ $(ZMPFOBJS) mld_z_extprol_bld.o mld_z_lev_aggrmap_bld.o mld_z_lev_aggrmat_asb.o -CINNEROBJS= mld_ccoarse_bld.o mld_cmlprec_bld.o mld_c_bld_mlhier_aggsize.o mld_c_bld_mlhier_array.o \ +CINNEROBJS= mld_cmlprec_bld.o mld_c_bld_mlhier_aggsize.o mld_c_bld_mlhier_array.o \ mld_c_ml_prec_bld.o mld_c_hierarchy_bld.o \ mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \ mld_c_dec_map_bld.o mld_cmlprec_aply.o mld_caggrmat_asb.o \ From 8f9d1fd59b57f9c63e52b4fa6744ed35d260d871 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 30 Sep 2016 19:34:27 +0000 Subject: [PATCH 16/21] mld2p4-extaggr: mlprec/impl/mld_caggrmat_asb.f90 mlprec/impl/mld_daggrmat_asb.f90 mlprec/impl/mld_saggrmat_asb.f90 mlprec/impl/mld_zaggrmat_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 Fix import and interface. --- mlprec/impl/mld_caggrmat_asb.f90 | 10 +++++----- mlprec/impl/mld_daggrmat_asb.f90 | 10 +++++----- mlprec/impl/mld_saggrmat_asb.f90 | 10 +++++----- mlprec/impl/mld_zaggrmat_asb.f90 | 10 +++++----- mlprec/mld_c_inner_mod.f90 | 3 ++- mlprec/mld_d_inner_mod.f90 | 3 ++- mlprec/mld_s_inner_mod.f90 | 3 ++- mlprec/mld_z_inner_mod.f90 | 3 ++- 8 files changed, 28 insertions(+), 24 deletions(-) diff --git a/mlprec/impl/mld_caggrmat_asb.f90 b/mlprec/impl/mld_caggrmat_asb.f90 index 39f9cf11..ba0bda60 100644 --- a/mlprec/impl/mld_caggrmat_asb.f90 +++ b/mlprec/impl/mld_caggrmat_asb.f90 @@ -133,26 +133,26 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf call psb_info(ictxt, me, np) - select case (p%parms%aggr_kind) + select case (parms%aggr_kind) case (mld_no_smooth_) call mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) call mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) call mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & 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) + & parms,ac,op_prol,op_restr,info) case default info = psb_err_internal_error_ diff --git a/mlprec/impl/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 index f8422b0f..5ee9b0e4 100644 --- a/mlprec/impl/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -133,26 +133,26 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf call psb_info(ictxt, me, np) - select case (p%parms%aggr_kind) + select case (parms%aggr_kind) case (mld_no_smooth_) call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & 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) + & parms,ac,op_prol,op_restr,info) case default info = psb_err_internal_error_ diff --git a/mlprec/impl/mld_saggrmat_asb.f90 b/mlprec/impl/mld_saggrmat_asb.f90 index bbee5a6f..e540c117 100644 --- a/mlprec/impl/mld_saggrmat_asb.f90 +++ b/mlprec/impl/mld_saggrmat_asb.f90 @@ -133,26 +133,26 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf call psb_info(ictxt, me, np) - select case (p%parms%aggr_kind) + select case (parms%aggr_kind) case (mld_no_smooth_) call mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) call mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) call mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & 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) + & parms,ac,op_prol,op_restr,info) case default info = psb_err_internal_error_ diff --git a/mlprec/impl/mld_zaggrmat_asb.f90 b/mlprec/impl/mld_zaggrmat_asb.f90 index 7a5cfeff..1cd620a5 100644 --- a/mlprec/impl/mld_zaggrmat_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_asb.f90 @@ -133,26 +133,26 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,inf call psb_info(ictxt, me, np) - select case (p%parms%aggr_kind) + select case (parms%aggr_kind) case (mld_no_smooth_) call mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_smooth_prol_) call mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & parms,ac,op_prol,op_restr,info) case(mld_biz_prol_) call mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & - & p%parms,ac,op_prol,op_restr,info) + & 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) + & parms,ac,op_prol,op_restr,info) case default info = psb_err_internal_error_ diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 8073b94c..467a193c 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -149,7 +149,7 @@ module mld_c_inner_mod type(psb_cspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_c_lev_aggrmap_bld - subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) + subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_ implicit none integer(psb_ipk_), intent(in) :: iorder @@ -158,6 +158,7 @@ module mld_c_inner_mod type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_cspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_caggrmap_bld end interface mld_aggrmap_bld diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index 19eab0ca..6fc4c07a 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -149,7 +149,7 @@ module mld_d_inner_mod type(psb_dspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_d_lev_aggrmap_bld - subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) + subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ implicit none integer(psb_ipk_), intent(in) :: iorder @@ -158,6 +158,7 @@ module mld_d_inner_mod type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_dspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_daggrmap_bld end interface mld_aggrmap_bld diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index 631a1a1f..279e45df 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -149,7 +149,7 @@ module mld_s_inner_mod type(psb_sspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_s_lev_aggrmap_bld - subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) + subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_ implicit none integer(psb_ipk_), intent(in) :: iorder @@ -158,6 +158,7 @@ module mld_s_inner_mod type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_sspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_saggrmap_bld end interface mld_aggrmap_bld diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index bf5d416a..72e64ac6 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -149,7 +149,7 @@ module mld_z_inner_mod type(psb_zspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_z_lev_aggrmap_bld - subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) + subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ implicit none integer(psb_ipk_), intent(in) :: iorder @@ -158,6 +158,7 @@ module mld_z_inner_mod type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) + type(psb_zspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info end subroutine mld_zaggrmap_bld end interface mld_aggrmap_bld From 466e0b442a54a82314732e11b8f4854db2132fbe Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 1 Oct 2016 18:15:21 +0000 Subject: [PATCH 17/21] mld2p4-extaggr: mlprec/impl/mld_cprecinit.F90 mlprec/impl/mld_dprecinit.F90 mlprec/impl/mld_sprecinit.F90 mlprec/impl/mld_zprecinit.F90 mlprec/mld_base_prec_type.F90 tests/pdegen/mld_d_pde2d.f90 tests/pdegen/mld_d_pde3d.f90 tests/pdegen/mld_s_pde2d.f90 tests/pdegen/mld_s_pde3d.f90 tests/pdegen/runs/ppde.inp Initialize aggr_filter. Update test programs to control dump and filtering from input file. --- mlprec/impl/mld_cprecinit.F90 | 1 + mlprec/impl/mld_dprecinit.F90 | 1 + mlprec/impl/mld_sprecinit.F90 | 1 + mlprec/impl/mld_zprecinit.F90 | 1 + mlprec/mld_base_prec_type.F90 | 3 ++ tests/pdegen/mld_d_pde2d.f90 | 47 +++++++++++++++++-------- tests/pdegen/mld_d_pde3d.f90 | 39 +++++++++++---------- tests/pdegen/mld_s_pde2d.f90 | 61 +++++++++++++++++++++----------- tests/pdegen/mld_s_pde3d.f90 | 65 ++++++++++++++++++++++------------- tests/pdegen/runs/ppde.inp | 9 ++--- 10 files changed, 148 insertions(+), 80 deletions(-) diff --git a/mlprec/impl/mld_cprecinit.F90 b/mlprec/impl/mld_cprecinit.F90 index 3681caac..7435f11f 100644 --- a/mlprec/impl/mld_cprecinit.F90 +++ b/mlprec/impl/mld_cprecinit.F90 @@ -207,6 +207,7 @@ subroutine mld_cprecinit(p,ptype,info,nlev) do ilev_=1,nlev_ call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) call p%precv(ilev_)%set(mld_aggr_scale_,scale,info) + call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info) end do case default diff --git a/mlprec/impl/mld_dprecinit.F90 b/mlprec/impl/mld_dprecinit.F90 index 3276c9e7..cdb3f7b2 100644 --- a/mlprec/impl/mld_dprecinit.F90 +++ b/mlprec/impl/mld_dprecinit.F90 @@ -212,6 +212,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev) do ilev_=1,nlev_ call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) call p%precv(ilev_)%set(mld_aggr_scale_,scale,info) + call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info) end do case default diff --git a/mlprec/impl/mld_sprecinit.F90 b/mlprec/impl/mld_sprecinit.F90 index 5474d9b5..692b55ca 100644 --- a/mlprec/impl/mld_sprecinit.F90 +++ b/mlprec/impl/mld_sprecinit.F90 @@ -207,6 +207,7 @@ subroutine mld_sprecinit(p,ptype,info,nlev) do ilev_=1,nlev_ call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) call p%precv(ilev_)%set(mld_aggr_scale_,scale,info) + call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info) end do case default diff --git a/mlprec/impl/mld_zprecinit.F90 b/mlprec/impl/mld_zprecinit.F90 index 548f7d85..f6f9a4b7 100644 --- a/mlprec/impl/mld_zprecinit.F90 +++ b/mlprec/impl/mld_zprecinit.F90 @@ -212,6 +212,7 @@ subroutine mld_zprecinit(p,ptype,info,nlev) do ilev_=1,nlev_ call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) call p%precv(ilev_)%set(mld_aggr_scale_,scale,info) + call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info) end do case default diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 2fbdec20..1389568b 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -334,6 +334,8 @@ module mld_base_prec_type character(len=15), parameter, private :: & & aggr_kinds(0:3)=(/'unsmoothed ','smoothed ',& & 'min energy ','bizr. smoothed'/) + character(len=15), parameter, private :: & + & aggr_filters(0:1)=(/'no filtering ','filtering '/) character(len=15), parameter, private :: & & matrix_names(0:1)=(/'distributed ','replicated '/) character(len=18), parameter, private :: & @@ -603,6 +605,7 @@ contains write(iout,*) ' Aggregation type: ', & & aggr_kinds(pm%aggr_kind) if (pm%aggr_kind /= mld_no_smooth_) then + write(iout,*) ' with: ', aggr_filters(pm%aggr_filter) if (pm%aggr_omega_alg == mld_eig_est_) then write(iout,*) ' Damping omega computation: spectral radius estimate' write(iout,*) ' Spectral radius estimate: ', & diff --git a/tests/pdegen/mld_d_pde2d.f90 b/tests/pdegen/mld_d_pde2d.f90 index a8720a61..a085aa3e 100644 --- a/tests/pdegen/mld_d_pde2d.f90 +++ b/tests/pdegen/mld_d_pde2d.f90 @@ -1,8 +1,8 @@ !!!$ !!$ -!!$ MLD2P4 version 2.0 +!!$ MLD2P4 version 2.1 !!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.4) !!$ !!$ (C) Copyright 2008, 2010, 2012, 2015 !!$ @@ -69,34 +69,34 @@ contains ! functions parametrizing the differential equation ! function b1(x,y) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: b1 real(psb_dpk_), intent(in) :: x,y - b1=0.d0/sqrt(2.d0) + b1=dzero/sqrt((2*done)) end function b1 function b2(x,y) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: b2 real(psb_dpk_), intent(in) :: x,y - b2=0.d0/sqrt(2.d0) + b2=dzero/sqrt((2*done)) end function b2 function c(x,y) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: c real(psb_dpk_), intent(in) :: x,y - c=0.d0 + c=dzero end function c function a1(x,y) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: a1 real(psb_dpk_), intent(in) :: x,y - a1=1.d0!/80 + a1=done!/80 end function a1 function a2(x,y) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: a2 real(psb_dpk_), intent(in) :: x,y - a2=1.d0!/80 + a2=done!/80 end function a2 function g(x,y) use psb_base_mod, only : psb_dpk_, done, dzero @@ -160,6 +160,7 @@ program mld_d_pde2d character(len=16) :: aggrkind ! smoothed/raw aggregatin character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_ord ! Ordering for aggregation + character(len=16) :: aggr_filter ! Use filtering? character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing integer(psb_ipk_) :: csize ! aggregation size at which to stop. @@ -175,6 +176,8 @@ program mld_d_pde2d type(precdata) :: prectype type(psb_d_coo_sparse_mat) :: acoo ! other variables + logical :: dump_prec + character(len=40) :: dump_prefix integer(psb_ipk_) :: info, i character(len=20) :: name,ch_err @@ -203,7 +206,8 @@ program mld_d_pde2d ! ! get parameters ! - call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,& + & dump_prec,dump_prefix) ! ! allocate and fill in the coefficient matrix, rhs and initial guess @@ -246,6 +250,7 @@ program mld_d_pde2d call mld_precset(prec,'aggr_kind', prectype%aggrkind,info) call mld_precset(prec,'aggr_alg', prectype%aggr_alg,info) call mld_precset(prec,'aggr_ord', prectype%aggr_ord,info) + call mld_precset(prec,'aggr_filter', prectype%aggr_filter, info) call psb_barrier(ictxt) t1 = psb_wtime() @@ -368,6 +373,10 @@ program mld_d_pde2d write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize end if + if (dump_prec) call prec%dump(info,prefix=trim(dump_prefix),& + & ac=.true.,solver=.true.,smoother=.true.,rp=.true.,global_num=.true.) + + ! ! cleanup storage and exit ! @@ -392,13 +401,17 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,& + & dump_prec,dump_prefix) + integer(psb_ipk_) :: ictxt type(precdata) :: prectype character(len=*) :: kmethd, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst integer(psb_ipk_) :: np, iam, info real(psb_dpk_) :: eps + logical :: dump_prec + character(len=*) :: dump_prefix character(len=20) :: buffer call psb_info(ictxt, iam, np) @@ -412,6 +425,8 @@ contains call read_data(itrace,psb_inp_unit) call read_data(irst,psb_inp_unit) call read_data(eps,psb_inp_unit) + call read_data(dump_prec,psb_inp_unit) + call read_data(dump_prefix,psb_inp_unit) call read_data(prectype%descr,psb_inp_unit) ! verbose description of the prec call read_data(prectype%prec,psb_inp_unit) ! overall prectype call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels @@ -422,6 +437,7 @@ contains call read_data(prectype%aggrkind,psb_inp_unit) ! smoothed/nonsmoothed/minenergy aggregatin call read_data(prectype%aggr_alg,psb_inp_unit) ! decoupled or sym. decoupled aggregation call read_data(prectype%aggr_ord,psb_inp_unit) ! aggregation ordering: natural, node degree + call read_data(prectype%aggr_filter,psb_inp_unit) ! aggregation filtering: filter, no_filter call read_data(prectype%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prectype%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps @@ -450,6 +466,8 @@ contains call psb_bcast(ictxt,itrace) call psb_bcast(ictxt,irst) call psb_bcast(ictxt,eps) + call psb_bcast(ictxt,dump_prec) + call psb_bcast(ictxt,dump_prefix) call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec call psb_bcast(ictxt,prectype%prec) ! overall prectype call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels @@ -460,6 +478,7 @@ contains call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation call psb_bcast(ictxt,prectype%aggr_ord) ! aggregation ordering: natural, node degree + call psb_bcast(ictxt,prectype%aggr_filter) ! aggregation filtering: filter, no_filter call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps diff --git a/tests/pdegen/mld_d_pde3d.f90 b/tests/pdegen/mld_d_pde3d.f90 index 6a29ed84..1dae12e1 100644 --- a/tests/pdegen/mld_d_pde3d.f90 +++ b/tests/pdegen/mld_d_pde3d.f90 @@ -68,49 +68,49 @@ contains ! functions parametrizing the differential equation ! function b1(x,y,z) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: b1 real(psb_dpk_), intent(in) :: x,y,z - b1=0.d0/sqrt(3.d0) + b1=dzero/sqrt((3*done)) end function b1 function b2(x,y,z) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: b2 real(psb_dpk_), intent(in) :: x,y,z - b2=0.d0/sqrt(3.d0) + b2=dzero/sqrt((3*done)) end function b2 function b3(x,y,z) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: b3 real(psb_dpk_), intent(in) :: x,y,z - b3=0.d0/sqrt(3.d0) + b3=dzero/sqrt((3*done)) end function b3 function c(x,y,z) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: c real(psb_dpk_), intent(in) :: x,y,z - c=0.d0 + c=dzero end function c function a1(x,y,z) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: a1 real(psb_dpk_), intent(in) :: x,y,z - a1=1.d0!/80 + a1=done!/80 end function a1 function a2(x,y,z) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: a2 real(psb_dpk_), intent(in) :: x,y,z - a2=1.d0!/80 + a2=done!/80 end function a2 function a3(x,y,z) - use psb_base_mod, only : psb_dpk_ + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: a3 real(psb_dpk_), intent(in) :: x,y,z - a3=1.d0!/80 + a3=done!/80 end function a3 function g(x,y,z) - use psb_base_mod, only : psb_dpk_, done, dzero + use psb_base_mod, only : psb_dpk_,done,dzero real(psb_dpk_) :: g real(psb_dpk_), intent(in) :: x,y,z g = dzero @@ -171,6 +171,7 @@ program mld_d_pde3d character(len=16) :: aggrkind ! smoothed/raw aggregatin character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_ord ! Ordering for aggregation + character(len=16) :: aggr_filter ! Use filtering? character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing integer(psb_ipk_) :: csize ! aggregation size at which to stop. @@ -186,8 +187,8 @@ program mld_d_pde3d type(precdata) :: prectype type(psb_d_coo_sparse_mat) :: acoo ! other variables - character(len=20) :: dump_prefix - logical :: dump_sol=.false., dump_prec=.false. + logical :: dump_prec + character(len=40) :: dump_prefix integer(psb_ipk_) :: info, i character(len=20) :: name,ch_err @@ -261,7 +262,7 @@ program mld_d_pde3d call mld_precset(prec,'aggr_kind', prectype%aggrkind,info) call mld_precset(prec,'aggr_alg', prectype%aggr_alg,info) call mld_precset(prec,'aggr_ord', prectype%aggr_ord,info) - call mld_precset(prec,'aggr_filter', mld_filter_mat_, info) + call mld_precset(prec,'aggr_filter', prectype%aggr_filter, info) call psb_barrier(ictxt) t1 = psb_wtime() @@ -448,6 +449,7 @@ contains call read_data(prectype%aggrkind,psb_inp_unit) ! smoothed/nonsmoothed/minenergy aggregatin call read_data(prectype%aggr_alg,psb_inp_unit) ! decoupled or sym. decoupled aggregation call read_data(prectype%aggr_ord,psb_inp_unit) ! aggregation ordering: natural, node degree + call read_data(prectype%aggr_filter,psb_inp_unit) ! aggregation filtering: filter, no_filter call read_data(prectype%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prectype%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps @@ -488,6 +490,7 @@ contains call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation call psb_bcast(ictxt,prectype%aggr_ord) ! aggregation ordering: natural, node degree + call psb_bcast(ictxt,prectype%aggr_filter) ! aggregation filtering: filter, no_filter call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps diff --git a/tests/pdegen/mld_s_pde2d.f90 b/tests/pdegen/mld_s_pde2d.f90 index 7627d389..7177c33c 100644 --- a/tests/pdegen/mld_s_pde2d.f90 +++ b/tests/pdegen/mld_s_pde2d.f90 @@ -1,8 +1,8 @@ !!!$ !!$ -!!$ MLD2P4 version 2.0 +!!$ MLD2P4 version 2.1 !!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.4) !!$ !!$ (C) Copyright 2008, 2010, 2012, 2015 !!$ @@ -69,43 +69,43 @@ contains ! functions parametrizing the differential equation ! function b1(x,y) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: b1 real(psb_spk_), intent(in) :: x,y - b1=0.d0/sqrt(2.d0) + b1=szero/sqrt((2*sone)) end function b1 function b2(x,y) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: b2 real(psb_spk_), intent(in) :: x,y - b2=0.d0/sqrt(2.d0) + b2=szero/sqrt((2*sone)) end function b2 function c(x,y) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: c real(psb_spk_), intent(in) :: x,y - c=0.d0 + c=szero end function c function a1(x,y) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: a1 real(psb_spk_), intent(in) :: x,y - a1=1.d0!/80 + a1=sone!/80 end function a1 function a2(x,y) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: a2 real(psb_spk_), intent(in) :: x,y - a2=1.d0!/80 + a2=sone!/80 end function a2 function g(x,y) - use psb_base_mod, only : psb_spk_, done, dzero + use psb_base_mod, only : psb_spk_, sone, szero real(psb_spk_) :: g real(psb_spk_), intent(in) :: x,y - g = dzero - if (x == done) then - g = done - else if (x == dzero) then + g = szero + if (x == sone) then + g = sone + else if (x == szero) then g = exp(-y**2) end if end function g @@ -160,6 +160,7 @@ program mld_s_pde2d character(len=16) :: aggrkind ! smoothed/raw aggregatin character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_ord ! Ordering for aggregation + character(len=16) :: aggr_filter ! Use filtering? character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing integer(psb_ipk_) :: csize ! aggregation size at which to stop. @@ -175,6 +176,8 @@ program mld_s_pde2d type(precdata) :: prectype type(psb_s_coo_sparse_mat) :: acoo ! other variables + logical :: dump_prec + character(len=40) :: dump_prefix integer(psb_ipk_) :: info, i character(len=20) :: name,ch_err @@ -203,7 +206,8 @@ program mld_s_pde2d ! ! get parameters ! - call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,& + & dump_prec,dump_prefix) ! ! allocate and fill in the coefficient matrix, rhs and initial guess @@ -241,11 +245,12 @@ program mld_s_pde2d if (prectype%mnaggratio>0)& & call mld_precset(prec,'min_aggr_ratio', prectype%mnaggratio, info) end if - if (prectype%athres >= dzero) & + if (prectype%athres >= szero) & & call mld_precset(prec,'aggr_thresh', prectype%athres, info) call mld_precset(prec,'aggr_kind', prectype%aggrkind,info) call mld_precset(prec,'aggr_alg', prectype%aggr_alg,info) call mld_precset(prec,'aggr_ord', prectype%aggr_ord,info) + call mld_precset(prec,'aggr_filter', prectype%aggr_filter, info) call psb_barrier(ictxt) t1 = psb_wtime() @@ -300,7 +305,7 @@ program mld_s_pde2d call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info) call mld_precset(prec,'sub_iluthrs', prectype%thr1, info) call psb_barrier(ictxt) - thier = dzero + thier = szero t1 = psb_wtime() call mld_precbld(a,desc_a,prec,info) if(info /= psb_success_) then @@ -368,6 +373,10 @@ program mld_s_pde2d write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize end if + if (dump_prec) call prec%dump(info,prefix=trim(dump_prefix),& + & ac=.true.,solver=.true.,smoother=.true.,rp=.true.,global_num=.true.) + + ! ! cleanup storage and exit ! @@ -392,13 +401,17 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,& + & dump_prec,dump_prefix) + integer(psb_ipk_) :: ictxt type(precdata) :: prectype character(len=*) :: kmethd, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst integer(psb_ipk_) :: np, iam, info real(psb_spk_) :: eps + logical :: dump_prec + character(len=*) :: dump_prefix character(len=20) :: buffer call psb_info(ictxt, iam, np) @@ -412,6 +425,8 @@ contains call read_data(itrace,psb_inp_unit) call read_data(irst,psb_inp_unit) call read_data(eps,psb_inp_unit) + call read_data(dump_prec,psb_inp_unit) + call read_data(dump_prefix,psb_inp_unit) call read_data(prectype%descr,psb_inp_unit) ! verbose description of the prec call read_data(prectype%prec,psb_inp_unit) ! overall prectype call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels @@ -422,6 +437,7 @@ contains call read_data(prectype%aggrkind,psb_inp_unit) ! smoothed/nonsmoothed/minenergy aggregatin call read_data(prectype%aggr_alg,psb_inp_unit) ! decoupled or sym. decoupled aggregation call read_data(prectype%aggr_ord,psb_inp_unit) ! aggregation ordering: natural, node degree + call read_data(prectype%aggr_filter,psb_inp_unit) ! aggregation filtering: filter, no_filter call read_data(prectype%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prectype%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps @@ -450,6 +466,8 @@ contains call psb_bcast(ictxt,itrace) call psb_bcast(ictxt,irst) call psb_bcast(ictxt,eps) + call psb_bcast(ictxt,dump_prec) + call psb_bcast(ictxt,dump_prefix) call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec call psb_bcast(ictxt,prectype%prec) ! overall prectype call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels @@ -460,6 +478,7 @@ contains call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation call psb_bcast(ictxt,prectype%aggr_ord) ! aggregation ordering: natural, node degree + call psb_bcast(ictxt,prectype%aggr_filter) ! aggregation filtering: filter, no_filter call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps diff --git a/tests/pdegen/mld_s_pde3d.f90 b/tests/pdegen/mld_s_pde3d.f90 index c2cb640e..7515522c 100644 --- a/tests/pdegen/mld_s_pde3d.f90 +++ b/tests/pdegen/mld_s_pde3d.f90 @@ -68,55 +68,55 @@ contains ! functions parametrizing the differential equation ! function b1(x,y,z) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: b1 real(psb_spk_), intent(in) :: x,y,z - b1=0.d0/sqrt(3.d0) + b1=szero/sqrt((3*sone)) end function b1 function b2(x,y,z) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: b2 real(psb_spk_), intent(in) :: x,y,z - b2=0.d0/sqrt(3.d0) + b2=szero/sqrt((3*sone)) end function b2 function b3(x,y,z) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: b3 real(psb_spk_), intent(in) :: x,y,z - b3=0.d0/sqrt(3.d0) + b3=szero/sqrt((3*sone)) end function b3 function c(x,y,z) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: c real(psb_spk_), intent(in) :: x,y,z - c=0.d0 + c=szero end function c function a1(x,y,z) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: a1 real(psb_spk_), intent(in) :: x,y,z - a1=1.d0!/80 + a1=sone!/80 end function a1 function a2(x,y,z) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: a2 real(psb_spk_), intent(in) :: x,y,z - a2=1.d0!/80 + a2=sone!/80 end function a2 function a3(x,y,z) - use psb_base_mod, only : psb_spk_ + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: a3 real(psb_spk_), intent(in) :: x,y,z - a3=1.d0!/80 + a3=sone!/80 end function a3 function g(x,y,z) - use psb_base_mod, only : psb_spk_, done, dzero + use psb_base_mod, only : psb_spk_,sone,szero real(psb_spk_) :: g real(psb_spk_), intent(in) :: x,y,z - g = dzero - if (x == done) then - g = done - else if (x == dzero) then + g = szero + if (x == sone) then + g = sone + else if (x == szero) then g = exp(y**2-z**2) end if end function g @@ -171,6 +171,7 @@ program mld_s_pde3d character(len=16) :: aggrkind ! smoothed/raw aggregatin character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_ord ! Ordering for aggregation + character(len=16) :: aggr_filter ! Use filtering? character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing integer(psb_ipk_) :: csize ! aggregation size at which to stop. @@ -186,6 +187,8 @@ program mld_s_pde3d type(precdata) :: prectype type(psb_s_coo_sparse_mat) :: acoo ! other variables + logical :: dump_prec + character(len=40) :: dump_prefix integer(psb_ipk_) :: info, i character(len=20) :: name,ch_err @@ -214,7 +217,8 @@ program mld_s_pde3d ! ! get parameters ! - call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,& + &dump_prec,dump_prefix) ! ! allocate and fill in the coefficient matrix, rhs and initial guess @@ -253,11 +257,12 @@ program mld_s_pde3d if (prectype%mnaggratio>0)& & call mld_precset(prec,'min_aggr_ratio', prectype%mnaggratio, info) end if - if (prectype%athres >= dzero) & + if (prectype%athres >= szero) & & call mld_precset(prec,'aggr_thresh', prectype%athres, info) call mld_precset(prec,'aggr_kind', prectype%aggrkind,info) call mld_precset(prec,'aggr_alg', prectype%aggr_alg,info) call mld_precset(prec,'aggr_ord', prectype%aggr_ord,info) + call mld_precset(prec,'aggr_filter', prectype%aggr_filter, info) call psb_barrier(ictxt) t1 = psb_wtime() @@ -312,7 +317,7 @@ program mld_s_pde3d call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info) call mld_precset(prec,'sub_iluthrs', prectype%thr1, info) call psb_barrier(ictxt) - thier = dzero + thier = szero t1 = psb_wtime() call mld_precbld(a,desc_a,prec,info) if(info /= psb_success_) then @@ -380,6 +385,10 @@ program mld_s_pde3d write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize end if + if (dump_prec) call prec%dump(info,prefix=trim(dump_prefix),& + & ac=.true.,solver=.true.,smoother=.true.,rp=.true.,global_num=.true.) + + ! ! cleanup storage and exit ! @@ -404,13 +413,17 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,& + & dump_prec,dump_prefix) + integer(psb_ipk_) :: ictxt type(precdata) :: prectype character(len=*) :: kmethd, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst integer(psb_ipk_) :: np, iam, info real(psb_spk_) :: eps + logical :: dump_prec + character(len=*) :: dump_prefix character(len=20) :: buffer call psb_info(ictxt, iam, np) @@ -424,6 +437,8 @@ contains call read_data(itrace,psb_inp_unit) call read_data(irst,psb_inp_unit) call read_data(eps,psb_inp_unit) + call read_data(dump_prec,psb_inp_unit) + call read_data(dump_prefix,psb_inp_unit) call read_data(prectype%descr,psb_inp_unit) ! verbose description of the prec call read_data(prectype%prec,psb_inp_unit) ! overall prectype call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels @@ -434,6 +449,7 @@ contains call read_data(prectype%aggrkind,psb_inp_unit) ! smoothed/nonsmoothed/minenergy aggregatin call read_data(prectype%aggr_alg,psb_inp_unit) ! decoupled or sym. decoupled aggregation call read_data(prectype%aggr_ord,psb_inp_unit) ! aggregation ordering: natural, node degree + call read_data(prectype%aggr_filter,psb_inp_unit) ! aggregation filtering: filter, no_filter call read_data(prectype%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prectype%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps @@ -462,6 +478,8 @@ contains call psb_bcast(ictxt,itrace) call psb_bcast(ictxt,irst) call psb_bcast(ictxt,eps) + call psb_bcast(ictxt,dump_prec) + call psb_bcast(ictxt,dump_prefix) call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec call psb_bcast(ictxt,prectype%prec) ! overall prectype call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels @@ -472,6 +490,7 @@ contains call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation call psb_bcast(ictxt,prectype%aggr_ord) ! aggregation ordering: natural, node degree + call psb_bcast(ictxt,prectype%aggr_filter) ! aggregation filtering: filter, no_filter call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index f692ddef..2feabc54 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 -0100 ! IDIM; domain size is idim**3 +0080 ! IDIM; domain size is idim**3 2 ! ISTOPC 2000 ! ITMAX 10 ! ITRACE @@ -18,6 +18,7 @@ ML ! Preconditioner NONE JACOBI BJAC AS ML SMOOTHED ! Type of aggregation: SMOOTHED, UNSMOOTHED, MINENERGY DEC ! Type of aggregation: DEC SYMDEC NATURAL ! Ordering of aggregation: NATURAL DEGREE +FILTER ! Filtering aggregation: FILTER NO_FILTER MULT ! Type of multilevel correction: ADD MULT KCYCLE VCYCLE WCYCLE KCYCLESYM TWOSIDE ! Side of correction: PRE POST TWOSIDE (ignored for ADD) 2 ! Smoother sweeps @@ -25,13 +26,13 @@ BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML 0 ! Number of overlap layers for AS preconditioner (at finest level) HALO ! AS Restriction operator NONE HALO NONE ! AS Prolongation operator NONE SUM AVG -FWGS ! Subdomain solver DSCALE ILU MILU ILUT FWGS BWGS MUMPS UMF SLU +ILU ! Subdomain solver DSCALE ILU MILU ILUT FWGS BWGS MUMPS UMF SLU 1 ! Solver sweeps for GS 0 ! Level-set N for ILU(N), and P for ILUT 1.d-4 ! Threshold T for ILU(T,P) DIST ! Coarse level: matrix distribution DIST REPL BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST MUMPS -FWGS ! Coarse level: subsolver DSCALE GS BWGS ILU UMF SLU SLUDIST MUMPS -0 ! Coarse level: Level-set N for ILU(N) +ILU ! Coarse level: subsolver DSCALE GS BWGS ILU UMF SLU SLUDIST MUMPS +1 ! Coarse level: Level-set N for ILU(N) 1.d-4 ! Coarse level: Threshold T for ILU(T,P) 2 ! Coarse level: Number of Jacobi sweeps From 0d36e968c3e73f40c956006efcbf4383eb5ee3a3 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 1 Oct 2016 19:01:35 +0000 Subject: [PATCH 18/21] mld2p4-extaggr: mlprec/impl/Makefile mlprec/impl/mld_c_bld_mlhier_aggsize.f90 mlprec/impl/mld_c_bld_mlhier_array.f90 mlprec/impl/mld_c_hierarchy_bld.f90 mlprec/impl/mld_cmlprec_bld.f90 mlprec/impl/mld_d_bld_mlhier_aggsize.f90 mlprec/impl/mld_d_bld_mlhier_array.f90 mlprec/impl/mld_d_hierarchy_bld.f90 mlprec/impl/mld_dmlprec_bld.f90 mlprec/impl/mld_s_bld_mlhier_aggsize.f90 mlprec/impl/mld_s_bld_mlhier_array.f90 mlprec/impl/mld_s_hierarchy_bld.f90 mlprec/impl/mld_smlprec_bld.f90 mlprec/impl/mld_z_bld_mlhier_aggsize.f90 mlprec/impl/mld_z_bld_mlhier_array.f90 mlprec/impl/mld_z_hierarchy_bld.f90 mlprec/impl/mld_zmlprec_bld.f90 mlprec/mld_c_prec_mod.f90 mlprec/mld_d_prec_mod.f90 mlprec/mld_s_prec_mod.f90 mlprec/mld_z_prec_mod.f90 Taken out mold from hierarchy_bld. bld_mlhier_aggsize and bld_mlhier_array are now superseded. --- mlprec/impl/Makefile | 8 +- mlprec/impl/mld_c_bld_mlhier_aggsize.f90 | 268 ----------------------- mlprec/impl/mld_c_bld_mlhier_array.f90 | 246 --------------------- mlprec/impl/mld_c_hierarchy_bld.f90 | 19 +- mlprec/impl/mld_cmlprec_bld.f90 | 2 +- mlprec/impl/mld_d_bld_mlhier_aggsize.f90 | 268 ----------------------- mlprec/impl/mld_d_bld_mlhier_array.f90 | 246 --------------------- mlprec/impl/mld_d_hierarchy_bld.f90 | 19 +- mlprec/impl/mld_dmlprec_bld.f90 | 2 +- mlprec/impl/mld_s_bld_mlhier_aggsize.f90 | 268 ----------------------- mlprec/impl/mld_s_bld_mlhier_array.f90 | 246 --------------------- mlprec/impl/mld_s_hierarchy_bld.f90 | 19 +- mlprec/impl/mld_smlprec_bld.f90 | 2 +- mlprec/impl/mld_z_bld_mlhier_aggsize.f90 | 268 ----------------------- mlprec/impl/mld_z_bld_mlhier_array.f90 | 246 --------------------- mlprec/impl/mld_z_hierarchy_bld.f90 | 19 +- mlprec/impl/mld_zmlprec_bld.f90 | 2 +- mlprec/mld_c_prec_mod.f90 | 8 +- mlprec/mld_d_prec_mod.f90 | 8 +- mlprec/mld_s_prec_mod.f90 | 8 +- mlprec/mld_z_prec_mod.f90 | 8 +- 21 files changed, 24 insertions(+), 2156 deletions(-) delete mode 100644 mlprec/impl/mld_c_bld_mlhier_aggsize.f90 delete mode 100644 mlprec/impl/mld_c_bld_mlhier_array.f90 delete mode 100644 mlprec/impl/mld_d_bld_mlhier_aggsize.f90 delete mode 100644 mlprec/impl/mld_d_bld_mlhier_array.f90 delete mode 100644 mlprec/impl/mld_s_bld_mlhier_aggsize.f90 delete mode 100644 mlprec/impl/mld_s_bld_mlhier_array.f90 delete mode 100644 mlprec/impl/mld_z_bld_mlhier_aggsize.f90 delete mode 100644 mlprec/impl/mld_z_bld_mlhier_array.f90 diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index 84b4bfd1..e03c55fc 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -22,25 +22,25 @@ MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS) MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o -DINNEROBJS= mld_dmlprec_bld.o mld_d_bld_mlhier_aggsize.o mld_d_bld_mlhier_array.o \ +DINNEROBJS= mld_dmlprec_bld.o \ mld_d_ml_prec_bld.o mld_d_hierarchy_bld.o \ mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \ mld_d_dec_map_bld.o mld_dmlprec_aply.o mld_daggrmat_asb.o \ $(DMPFOBJS) mld_d_extprol_bld.o mld_d_lev_aggrmap_bld.o mld_d_lev_aggrmat_asb.o -SINNEROBJS= mld_smlprec_bld.o mld_s_bld_mlhier_aggsize.o mld_s_bld_mlhier_array.o \ +SINNEROBJS= mld_smlprec_bld.o \ mld_s_ml_prec_bld.o mld_s_hierarchy_bld.o \ mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o mld_saggrmap_bld.o \ mld_s_dec_map_bld.o mld_smlprec_aply.o mld_saggrmat_asb.o \ $(SMPFOBJS) mld_s_extprol_bld.o mld_s_lev_aggrmap_bld.o mld_s_lev_aggrmat_asb.o -ZINNEROBJS= mld_zmlprec_bld.o mld_z_bld_mlhier_aggsize.o mld_z_bld_mlhier_array.o \ +ZINNEROBJS= mld_zmlprec_bld.o \ mld_z_ml_prec_bld.o mld_z_hierarchy_bld.o \ mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \ mld_z_dec_map_bld.o mld_zmlprec_aply.o mld_zaggrmat_asb.o \ $(ZMPFOBJS) mld_z_extprol_bld.o mld_z_lev_aggrmap_bld.o mld_z_lev_aggrmat_asb.o -CINNEROBJS= mld_cmlprec_bld.o mld_c_bld_mlhier_aggsize.o mld_c_bld_mlhier_array.o \ +CINNEROBJS= mld_cmlprec_bld.o \ mld_c_ml_prec_bld.o mld_c_hierarchy_bld.o \ mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \ mld_c_dec_map_bld.o mld_cmlprec_aply.o mld_caggrmat_asb.o \ diff --git a/mlprec/impl/mld_c_bld_mlhier_aggsize.f90 b/mlprec/impl/mld_c_bld_mlhier_aggsize.f90 deleted file mode 100644 index cf3ec60e..00000000 --- a/mlprec/impl/mld_c_bld_mlhier_aggsize.f90 +++ /dev/null @@ -1,268 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ 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. -!!$ -!!$ -! -! Build an aggregation hierarchy with a target aggregation size -! -! -subroutine mld_c_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) - use psb_base_mod - use mld_c_inner_mod, mld_protect_name => mld_c_bld_mlhier_aggsize - use mld_c_prec_mod - implicit none - integer(psb_ipk_), intent(in) :: casize,mxplevs - real(psb_spk_) :: mnaggratio - type(psb_cspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_c_onelev_type), allocatable, target, intent(inout) :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, iaggsize - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - integer(psb_ipk_) :: int_err(5) - character :: upd_ - class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2 - type(mld_sml_parms) :: baseparms, medparms, coarseparms - type(mld_c_onelev_node), pointer :: head, tail, newnode, current - real(psb_spk_) :: sizeratio - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_mlhier_aggsize' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - ! - ! New strategy to build according to coarse size. - ! - iszv = size(precv) - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if ((info == psb_success_).and.allocated(precv(1)%sm2a)) & - & allocate(base_sm2, source=precv(1)%sm2a,stat=info) - if ((info == psb_success_).and.allocated(precv(2)%sm2a)) & - & allocate(med_sm2, source=precv(2)%sm2a,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)*(current%item%parms%aggr_scale) - 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 - - current => current%next - tail => current - iaggsize = sum(current%item%map%naggr) - - if (iaggsize <= casize) then - ! - ! Target reached; but we may need to rebuild. - ! - exit list_build_loop - end if - if (newsz>2) then - sizeratio = iaggsize - sizeratio = sum(current%prev%item%map%naggr)/sizeratio - - if (sizeratio < mnaggratio) then - if (sizeratio > 1) exit list_build_loop - ! - ! We are not gaining - ! - newsz = newsz-1 - current => current%prev - 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 - exit list_build_loop - end if - end if - - end do list_build_loop - ! - ! At this point, we are at the list tail. - ! If the top aggregation parameters were different, then we need to rebuild; - ! the threshold has to be fixed before rebuliding, and the parms must be - ! copied anyway since they'll be used later for the smoother build. - ! - coarseparms%aggr_thresh = current%item%parms%aggr_thresh - - if (.not.mld_equal_aggregation(current%item%parms, coarseparms)) then - ! Need to rebuild. - 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 - else - ! Need only copy the parms. - current%item%parms = coarseparms - end if - ! - ! Ok, now allocate the output vector and fix items. - ! - do i=1,iszv - if (info == psb_success_) call precv(i)%free(info) - end do - if (info == psb_success_) deallocate(precv,stat=info) - if (info == psb_success_) allocate(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 - ! First do a move_alloc. - ! This handles the AC, DESC_AC and MAP fields - if (info == psb_success_) & - & call current%item%move_alloc(precv(i),info) - ! Now set the smoother/solver parts. - if (info == psb_success_) then - if (i ==1) then - allocate(precv(i)%sm,source=base_sm,stat=info) - if (allocated(base_sm2)) then - allocate(precv(i)%sm2a,source=base_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else if (i < newsz) then - allocate(precv(i)%sm,source=med_sm,stat=info) - if (allocated(med_sm2)) then - allocate(precv(i)%sm2a,source=med_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else - allocate(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 - precv(i)%base_a => a - precv(i)%base_desc => desc_a - else - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => 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_).and.(allocated(base_sm2))) call base_sm2%free(info) - if ((info == psb_success_).and.(allocated(med_sm2))) call med_sm2%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 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_c_bld_mlhier_aggsize diff --git a/mlprec/impl/mld_c_bld_mlhier_array.f90 b/mlprec/impl/mld_c_bld_mlhier_array.f90 deleted file mode 100644 index da0d2279..00000000 --- a/mlprec/impl/mld_c_bld_mlhier_array.f90 +++ /dev/null @@ -1,246 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ 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. -!!$ -!!$ - -subroutine mld_c_bld_mlhier_array(nplevs,a,desc_a,precv,info) - use psb_base_mod - use mld_c_inner_mod, mld_protect_name => mld_c_bld_mlhier_array - use mld_c_prec_mod - implicit none - integer(psb_ipk_), intent(inout) :: nplevs - type(psb_cspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_c_onelev_type),intent(inout), allocatable, target :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm - type(mld_sml_parms) :: baseparms, medparms, coarseparms - type(mld_c_onelev_type), allocatable :: tprecv(:) - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_array_hierarchy' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - iszv = size(precv) - - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=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 - - ! - ! - ! 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,precv(1)%parms) - iszv = size(precv) - ! - ! First set desired number of levels - ! - if (iszv /= nplevs) then - allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,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,iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - iszv = size(precv) - end if - - ! - ! Finest level first; remember to fix base_a and base_desc - ! - precv(1)%base_a => a - precv(1)%base_desc => desc_a - newsz = 0 - array_build_loop: do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,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(precv(i-1)%base_a,& - & precv(i-1)%base_desc, 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(precv(i)%map%naggr == precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop - end if - end do array_build_loop - - 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(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz-1 - call precv(i)%move_alloc(tprecv(i),info) - end do - call precv(iszv)%move_alloc(tprecv(newsz),info) - do i=newsz+1, iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - ! 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 - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end do - - i = iszv - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, 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 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_c_bld_mlhier_array diff --git a/mlprec/impl/mld_c_hierarchy_bld.f90 b/mlprec/impl/mld_c_hierarchy_bld.f90 index 04d8548b..bad8ba82 100644 --- a/mlprec/impl/mld_c_hierarchy_bld.f90 +++ b/mlprec/impl/mld_c_hierarchy_bld.f90 @@ -62,19 +62,8 @@ ! of the preconditioner to be built. ! info - integer, output. ! Error code. -! -! amold - class(psb_c_base_sparse_mat), input, optional -! Mold for the inner format of matrices contained in the -! preconditioner -! -! -! vmold - class(psb_c_base_vect_type), input, optional -! Mold for the inner format of vectors contained in the -! preconditioner -! -! ! -subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_c_hierarchy_bld(a,desc_a,p,info) use psb_base_mod use mld_c_inner_mod @@ -87,9 +76,6 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) type(psb_desc_type), intent(inout), target :: desc_a type(mld_cprec_type),intent(inout),target :: p integer(psb_ipk_), intent(out) :: info - class(psb_c_base_sparse_mat), intent(in), optional :: amold - class(psb_c_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables @@ -206,11 +192,10 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! 4. If the size of the array is different from target number of levels, ! reallocate; ! 5. Build the matrix hierarchy, stopping early if either the target - ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! coarse size is hit, or the gain falls below the min_aggr_ratio ! threshold. ! - if (nplevs <= 0) then if (casize <=0) then ! diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index d9e4b826..d3ef5b41 100644 --- a/mlprec/impl/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -119,7 +119,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold) & write(debug_unit,*) me,' ',trim(name),& & 'Entering ' - call mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_c_hierarchy_bld(a,desc_a,p,info) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_d_bld_mlhier_aggsize.f90 b/mlprec/impl/mld_d_bld_mlhier_aggsize.f90 deleted file mode 100644 index 838ef25c..00000000 --- a/mlprec/impl/mld_d_bld_mlhier_aggsize.f90 +++ /dev/null @@ -1,268 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ 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. -!!$ -!!$ -! -! Build an aggregation hierarchy with a target aggregation size -! -! -subroutine mld_d_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) - use psb_base_mod - use mld_d_inner_mod, mld_protect_name => mld_d_bld_mlhier_aggsize - use mld_d_prec_mod - implicit none - integer(psb_ipk_), intent(in) :: casize,mxplevs - real(psb_dpk_) :: mnaggratio - type(psb_dspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_d_onelev_type), allocatable, target, intent(inout) :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, iaggsize - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - integer(psb_ipk_) :: int_err(5) - character :: upd_ - class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2 - type(mld_dml_parms) :: baseparms, medparms, coarseparms - type(mld_d_onelev_node), pointer :: head, tail, newnode, current - real(psb_dpk_) :: sizeratio - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_mlhier_aggsize' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - ! - ! New strategy to build according to coarse size. - ! - iszv = size(precv) - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if ((info == psb_success_).and.allocated(precv(1)%sm2a)) & - & allocate(base_sm2, source=precv(1)%sm2a,stat=info) - if ((info == psb_success_).and.allocated(precv(2)%sm2a)) & - & allocate(med_sm2, source=precv(2)%sm2a,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)*(current%item%parms%aggr_scale) - 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 - - current => current%next - tail => current - iaggsize = sum(current%item%map%naggr) - - if (iaggsize <= casize) then - ! - ! Target reached; but we may need to rebuild. - ! - exit list_build_loop - end if - if (newsz>2) then - sizeratio = iaggsize - sizeratio = sum(current%prev%item%map%naggr)/sizeratio - - if (sizeratio < mnaggratio) then - if (sizeratio > 1) exit list_build_loop - ! - ! We are not gaining - ! - newsz = newsz-1 - current => current%prev - 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 - exit list_build_loop - end if - end if - - end do list_build_loop - ! - ! At this point, we are at the list tail. - ! If the top aggregation parameters were different, then we need to rebuild; - ! the threshold has to be fixed before rebuliding, and the parms must be - ! copied anyway since they'll be used later for the smoother build. - ! - coarseparms%aggr_thresh = current%item%parms%aggr_thresh - - if (.not.mld_equal_aggregation(current%item%parms, coarseparms)) then - ! Need to rebuild. - 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 - else - ! Need only copy the parms. - current%item%parms = coarseparms - end if - ! - ! Ok, now allocate the output vector and fix items. - ! - do i=1,iszv - if (info == psb_success_) call precv(i)%free(info) - end do - if (info == psb_success_) deallocate(precv,stat=info) - if (info == psb_success_) allocate(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 - ! First do a move_alloc. - ! This handles the AC, DESC_AC and MAP fields - if (info == psb_success_) & - & call current%item%move_alloc(precv(i),info) - ! Now set the smoother/solver parts. - if (info == psb_success_) then - if (i ==1) then - allocate(precv(i)%sm,source=base_sm,stat=info) - if (allocated(base_sm2)) then - allocate(precv(i)%sm2a,source=base_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else if (i < newsz) then - allocate(precv(i)%sm,source=med_sm,stat=info) - if (allocated(med_sm2)) then - allocate(precv(i)%sm2a,source=med_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else - allocate(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 - precv(i)%base_a => a - precv(i)%base_desc => desc_a - else - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => 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_).and.(allocated(base_sm2))) call base_sm2%free(info) - if ((info == psb_success_).and.(allocated(med_sm2))) call med_sm2%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 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_d_bld_mlhier_aggsize diff --git a/mlprec/impl/mld_d_bld_mlhier_array.f90 b/mlprec/impl/mld_d_bld_mlhier_array.f90 deleted file mode 100644 index 3618de1b..00000000 --- a/mlprec/impl/mld_d_bld_mlhier_array.f90 +++ /dev/null @@ -1,246 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ 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. -!!$ -!!$ - -subroutine mld_d_bld_mlhier_array(nplevs,a,desc_a,precv,info) - use psb_base_mod - use mld_d_inner_mod, mld_protect_name => mld_d_bld_mlhier_array - use mld_d_prec_mod - implicit none - integer(psb_ipk_), intent(inout) :: nplevs - type(psb_dspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_d_onelev_type),intent(inout), allocatable, target :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm - type(mld_dml_parms) :: baseparms, medparms, coarseparms - type(mld_d_onelev_type), allocatable :: tprecv(:) - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_array_hierarchy' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - iszv = size(precv) - - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=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 - - ! - ! - ! 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,precv(1)%parms) - iszv = size(precv) - ! - ! First set desired number of levels - ! - if (iszv /= nplevs) then - allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,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,iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - iszv = size(precv) - end if - - ! - ! Finest level first; remember to fix base_a and base_desc - ! - precv(1)%base_a => a - precv(1)%base_desc => desc_a - newsz = 0 - array_build_loop: do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,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(precv(i-1)%base_a,& - & precv(i-1)%base_desc, 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(precv(i)%map%naggr == precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop - end if - end do array_build_loop - - 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(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz-1 - call precv(i)%move_alloc(tprecv(i),info) - end do - call precv(iszv)%move_alloc(tprecv(newsz),info) - do i=newsz+1, iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - ! 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 - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end do - - i = iszv - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, 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 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_d_bld_mlhier_array diff --git a/mlprec/impl/mld_d_hierarchy_bld.f90 b/mlprec/impl/mld_d_hierarchy_bld.f90 index 42a33e94..e8af7fed 100644 --- a/mlprec/impl/mld_d_hierarchy_bld.f90 +++ b/mlprec/impl/mld_d_hierarchy_bld.f90 @@ -62,19 +62,8 @@ ! of the preconditioner to be built. ! info - integer, output. ! Error code. -! -! amold - class(psb_d_base_sparse_mat), input, optional -! Mold for the inner format of matrices contained in the -! preconditioner -! -! -! vmold - class(psb_d_base_vect_type), input, optional -! Mold for the inner format of vectors contained in the -! preconditioner -! -! ! -subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_d_hierarchy_bld(a,desc_a,p,info) use psb_base_mod use mld_d_inner_mod @@ -87,9 +76,6 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) type(psb_desc_type), intent(inout), target :: desc_a type(mld_dprec_type),intent(inout),target :: p integer(psb_ipk_), intent(out) :: info - class(psb_d_base_sparse_mat), intent(in), optional :: amold - class(psb_d_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables @@ -206,11 +192,10 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! 4. If the size of the array is different from target number of levels, ! reallocate; ! 5. Build the matrix hierarchy, stopping early if either the target - ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! coarse size is hit, or the gain falls below the min_aggr_ratio ! threshold. ! - if (nplevs <= 0) then if (casize <=0) then ! diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index ac2f3923..b5252739 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -119,7 +119,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold) & write(debug_unit,*) me,' ',trim(name),& & 'Entering ' - call mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_d_hierarchy_bld(a,desc_a,p,info) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_s_bld_mlhier_aggsize.f90 b/mlprec/impl/mld_s_bld_mlhier_aggsize.f90 deleted file mode 100644 index 9be3473c..00000000 --- a/mlprec/impl/mld_s_bld_mlhier_aggsize.f90 +++ /dev/null @@ -1,268 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ 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. -!!$ -!!$ -! -! Build an aggregation hierarchy with a target aggregation size -! -! -subroutine mld_s_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) - use psb_base_mod - use mld_s_inner_mod, mld_protect_name => mld_s_bld_mlhier_aggsize - use mld_s_prec_mod - implicit none - integer(psb_ipk_), intent(in) :: casize,mxplevs - real(psb_spk_) :: mnaggratio - type(psb_sspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_s_onelev_type), allocatable, target, intent(inout) :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, iaggsize - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - integer(psb_ipk_) :: int_err(5) - character :: upd_ - class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2 - type(mld_sml_parms) :: baseparms, medparms, coarseparms - type(mld_s_onelev_node), pointer :: head, tail, newnode, current - real(psb_spk_) :: sizeratio - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_mlhier_aggsize' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - ! - ! New strategy to build according to coarse size. - ! - iszv = size(precv) - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if ((info == psb_success_).and.allocated(precv(1)%sm2a)) & - & allocate(base_sm2, source=precv(1)%sm2a,stat=info) - if ((info == psb_success_).and.allocated(precv(2)%sm2a)) & - & allocate(med_sm2, source=precv(2)%sm2a,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)*(current%item%parms%aggr_scale) - 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 - - current => current%next - tail => current - iaggsize = sum(current%item%map%naggr) - - if (iaggsize <= casize) then - ! - ! Target reached; but we may need to rebuild. - ! - exit list_build_loop - end if - if (newsz>2) then - sizeratio = iaggsize - sizeratio = sum(current%prev%item%map%naggr)/sizeratio - - if (sizeratio < mnaggratio) then - if (sizeratio > 1) exit list_build_loop - ! - ! We are not gaining - ! - newsz = newsz-1 - current => current%prev - 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 - exit list_build_loop - end if - end if - - end do list_build_loop - ! - ! At this point, we are at the list tail. - ! If the top aggregation parameters were different, then we need to rebuild; - ! the threshold has to be fixed before rebuliding, and the parms must be - ! copied anyway since they'll be used later for the smoother build. - ! - coarseparms%aggr_thresh = current%item%parms%aggr_thresh - - if (.not.mld_equal_aggregation(current%item%parms, coarseparms)) then - ! Need to rebuild. - 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 - else - ! Need only copy the parms. - current%item%parms = coarseparms - end if - ! - ! Ok, now allocate the output vector and fix items. - ! - do i=1,iszv - if (info == psb_success_) call precv(i)%free(info) - end do - if (info == psb_success_) deallocate(precv,stat=info) - if (info == psb_success_) allocate(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 - ! First do a move_alloc. - ! This handles the AC, DESC_AC and MAP fields - if (info == psb_success_) & - & call current%item%move_alloc(precv(i),info) - ! Now set the smoother/solver parts. - if (info == psb_success_) then - if (i ==1) then - allocate(precv(i)%sm,source=base_sm,stat=info) - if (allocated(base_sm2)) then - allocate(precv(i)%sm2a,source=base_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else if (i < newsz) then - allocate(precv(i)%sm,source=med_sm,stat=info) - if (allocated(med_sm2)) then - allocate(precv(i)%sm2a,source=med_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else - allocate(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 - precv(i)%base_a => a - precv(i)%base_desc => desc_a - else - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => 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_).and.(allocated(base_sm2))) call base_sm2%free(info) - if ((info == psb_success_).and.(allocated(med_sm2))) call med_sm2%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 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_s_bld_mlhier_aggsize diff --git a/mlprec/impl/mld_s_bld_mlhier_array.f90 b/mlprec/impl/mld_s_bld_mlhier_array.f90 deleted file mode 100644 index 3f249d34..00000000 --- a/mlprec/impl/mld_s_bld_mlhier_array.f90 +++ /dev/null @@ -1,246 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ 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. -!!$ -!!$ - -subroutine mld_s_bld_mlhier_array(nplevs,a,desc_a,precv,info) - use psb_base_mod - use mld_s_inner_mod, mld_protect_name => mld_s_bld_mlhier_array - use mld_s_prec_mod - implicit none - integer(psb_ipk_), intent(inout) :: nplevs - type(psb_sspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_s_onelev_type),intent(inout), allocatable, target :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm - type(mld_sml_parms) :: baseparms, medparms, coarseparms - type(mld_s_onelev_type), allocatable :: tprecv(:) - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_array_hierarchy' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - iszv = size(precv) - - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=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 - - ! - ! - ! 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,precv(1)%parms) - iszv = size(precv) - ! - ! First set desired number of levels - ! - if (iszv /= nplevs) then - allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,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,iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - iszv = size(precv) - end if - - ! - ! Finest level first; remember to fix base_a and base_desc - ! - precv(1)%base_a => a - precv(1)%base_desc => desc_a - newsz = 0 - array_build_loop: do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,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(precv(i-1)%base_a,& - & precv(i-1)%base_desc, 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(precv(i)%map%naggr == precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop - end if - end do array_build_loop - - 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(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz-1 - call precv(i)%move_alloc(tprecv(i),info) - end do - call precv(iszv)%move_alloc(tprecv(newsz),info) - do i=newsz+1, iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - ! 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 - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end do - - i = iszv - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, 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 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_s_bld_mlhier_array diff --git a/mlprec/impl/mld_s_hierarchy_bld.f90 b/mlprec/impl/mld_s_hierarchy_bld.f90 index 3faf3f57..acd8aa53 100644 --- a/mlprec/impl/mld_s_hierarchy_bld.f90 +++ b/mlprec/impl/mld_s_hierarchy_bld.f90 @@ -62,19 +62,8 @@ ! of the preconditioner to be built. ! info - integer, output. ! Error code. -! -! amold - class(psb_s_base_sparse_mat), input, optional -! Mold for the inner format of matrices contained in the -! preconditioner -! -! -! vmold - class(psb_s_base_vect_type), input, optional -! Mold for the inner format of vectors contained in the -! preconditioner -! -! ! -subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_s_hierarchy_bld(a,desc_a,p,info) use psb_base_mod use mld_s_inner_mod @@ -87,9 +76,6 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) type(psb_desc_type), intent(inout), target :: desc_a type(mld_sprec_type),intent(inout),target :: p integer(psb_ipk_), intent(out) :: info - class(psb_s_base_sparse_mat), intent(in), optional :: amold - class(psb_s_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables @@ -206,11 +192,10 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! 4. If the size of the array is different from target number of levels, ! reallocate; ! 5. Build the matrix hierarchy, stopping early if either the target - ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! coarse size is hit, or the gain falls below the min_aggr_ratio ! threshold. ! - if (nplevs <= 0) then if (casize <=0) then ! diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index 8f9d4502..b96dc733 100644 --- a/mlprec/impl/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -119,7 +119,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold) & write(debug_unit,*) me,' ',trim(name),& & 'Entering ' - call mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_s_hierarchy_bld(a,desc_a,p,info) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_z_bld_mlhier_aggsize.f90 b/mlprec/impl/mld_z_bld_mlhier_aggsize.f90 deleted file mode 100644 index 9ae5da74..00000000 --- a/mlprec/impl/mld_z_bld_mlhier_aggsize.f90 +++ /dev/null @@ -1,268 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ 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. -!!$ -!!$ -! -! Build an aggregation hierarchy with a target aggregation size -! -! -subroutine mld_z_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) - use psb_base_mod - use mld_z_inner_mod, mld_protect_name => mld_z_bld_mlhier_aggsize - use mld_z_prec_mod - implicit none - integer(psb_ipk_), intent(in) :: casize,mxplevs - real(psb_dpk_) :: mnaggratio - type(psb_zspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_z_onelev_type), allocatable, target, intent(inout) :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, iaggsize - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - integer(psb_ipk_) :: int_err(5) - character :: upd_ - class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2 - type(mld_dml_parms) :: baseparms, medparms, coarseparms - type(mld_z_onelev_node), pointer :: head, tail, newnode, current - real(psb_dpk_) :: sizeratio - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_mlhier_aggsize' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - ! - ! New strategy to build according to coarse size. - ! - iszv = size(precv) - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if ((info == psb_success_).and.allocated(precv(1)%sm2a)) & - & allocate(base_sm2, source=precv(1)%sm2a,stat=info) - if ((info == psb_success_).and.allocated(precv(2)%sm2a)) & - & allocate(med_sm2, source=precv(2)%sm2a,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)*(current%item%parms%aggr_scale) - 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 - - current => current%next - tail => current - iaggsize = sum(current%item%map%naggr) - - if (iaggsize <= casize) then - ! - ! Target reached; but we may need to rebuild. - ! - exit list_build_loop - end if - if (newsz>2) then - sizeratio = iaggsize - sizeratio = sum(current%prev%item%map%naggr)/sizeratio - - if (sizeratio < mnaggratio) then - if (sizeratio > 1) exit list_build_loop - ! - ! We are not gaining - ! - newsz = newsz-1 - current => current%prev - 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 - exit list_build_loop - end if - end if - - end do list_build_loop - ! - ! At this point, we are at the list tail. - ! If the top aggregation parameters were different, then we need to rebuild; - ! the threshold has to be fixed before rebuliding, and the parms must be - ! copied anyway since they'll be used later for the smoother build. - ! - coarseparms%aggr_thresh = current%item%parms%aggr_thresh - - if (.not.mld_equal_aggregation(current%item%parms, coarseparms)) then - ! Need to rebuild. - 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 - else - ! Need only copy the parms. - current%item%parms = coarseparms - end if - ! - ! Ok, now allocate the output vector and fix items. - ! - do i=1,iszv - if (info == psb_success_) call precv(i)%free(info) - end do - if (info == psb_success_) deallocate(precv,stat=info) - if (info == psb_success_) allocate(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 - ! First do a move_alloc. - ! This handles the AC, DESC_AC and MAP fields - if (info == psb_success_) & - & call current%item%move_alloc(precv(i),info) - ! Now set the smoother/solver parts. - if (info == psb_success_) then - if (i ==1) then - allocate(precv(i)%sm,source=base_sm,stat=info) - if (allocated(base_sm2)) then - allocate(precv(i)%sm2a,source=base_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else if (i < newsz) then - allocate(precv(i)%sm,source=med_sm,stat=info) - if (allocated(med_sm2)) then - allocate(precv(i)%sm2a,source=med_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else - allocate(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 - precv(i)%base_a => a - precv(i)%base_desc => desc_a - else - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => 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_).and.(allocated(base_sm2))) call base_sm2%free(info) - if ((info == psb_success_).and.(allocated(med_sm2))) call med_sm2%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 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_z_bld_mlhier_aggsize diff --git a/mlprec/impl/mld_z_bld_mlhier_array.f90 b/mlprec/impl/mld_z_bld_mlhier_array.f90 deleted file mode 100644 index 206cdf30..00000000 --- a/mlprec/impl/mld_z_bld_mlhier_array.f90 +++ /dev/null @@ -1,246 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ 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. -!!$ -!!$ - -subroutine mld_z_bld_mlhier_array(nplevs,a,desc_a,precv,info) - use psb_base_mod - use mld_z_inner_mod, mld_protect_name => mld_z_bld_mlhier_array - use mld_z_prec_mod - implicit none - integer(psb_ipk_), intent(inout) :: nplevs - type(psb_zspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_z_onelev_type),intent(inout), allocatable, target :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm - type(mld_dml_parms) :: baseparms, medparms, coarseparms - type(mld_z_onelev_type), allocatable :: tprecv(:) - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_array_hierarchy' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - iszv = size(precv) - - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=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 - - ! - ! - ! 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,precv(1)%parms) - iszv = size(precv) - ! - ! First set desired number of levels - ! - if (iszv /= nplevs) then - allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,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,iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - iszv = size(precv) - end if - - ! - ! Finest level first; remember to fix base_a and base_desc - ! - precv(1)%base_a => a - precv(1)%base_desc => desc_a - newsz = 0 - array_build_loop: do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,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(precv(i-1)%base_a,& - & precv(i-1)%base_desc, 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(precv(i)%map%naggr == precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop - end if - end do array_build_loop - - 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(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz-1 - call precv(i)%move_alloc(tprecv(i),info) - end do - call precv(iszv)%move_alloc(tprecv(newsz),info) - do i=newsz+1, iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - ! 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 - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end do - - i = iszv - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, 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 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_z_bld_mlhier_array diff --git a/mlprec/impl/mld_z_hierarchy_bld.f90 b/mlprec/impl/mld_z_hierarchy_bld.f90 index 47689ee5..33982c77 100644 --- a/mlprec/impl/mld_z_hierarchy_bld.f90 +++ b/mlprec/impl/mld_z_hierarchy_bld.f90 @@ -62,19 +62,8 @@ ! of the preconditioner to be built. ! info - integer, output. ! Error code. -! -! amold - class(psb_z_base_sparse_mat), input, optional -! Mold for the inner format of matrices contained in the -! preconditioner -! -! -! vmold - class(psb_z_base_vect_type), input, optional -! Mold for the inner format of vectors contained in the -! preconditioner -! -! ! -subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_z_hierarchy_bld(a,desc_a,p,info) use psb_base_mod use mld_z_inner_mod @@ -87,9 +76,6 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) type(psb_desc_type), intent(inout), target :: desc_a type(mld_zprec_type),intent(inout),target :: p integer(psb_ipk_), intent(out) :: info - class(psb_z_base_sparse_mat), intent(in), optional :: amold - class(psb_z_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables @@ -206,11 +192,10 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! 4. If the size of the array is different from target number of levels, ! reallocate; ! 5. Build the matrix hierarchy, stopping early if either the target - ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! coarse size is hit, or the gain falls below the min_aggr_ratio ! threshold. ! - if (nplevs <= 0) then if (casize <=0) then ! diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index b1532029..7c292b1c 100644 --- a/mlprec/impl/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -119,7 +119,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold) & write(debug_unit,*) me,' ',trim(name),& & 'Entering ' - call mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_z_hierarchy_bld(a,desc_a,p,info) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index 5d0fea10..103d66c5 100644 --- a/mlprec/mld_c_prec_mod.f90 +++ b/mlprec/mld_c_prec_mod.f90 @@ -88,18 +88,14 @@ module mld_c_prec_mod end interface mld_precbld interface mld_hierarchy_bld - subroutine mld_c_hierarchy_bld(a,desc_a,prec,info,amold,vmold,imold) + subroutine mld_c_hierarchy_bld(a,desc_a,prec,info) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & - & psb_c_base_sparse_mat, psb_c_base_vect_type, & - & psb_i_base_vect_type, mld_cprec_type, psb_ipk_ + & mld_cprec_type, psb_ipk_ implicit none type(psb_cspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_cprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info - class(psb_c_base_sparse_mat), intent(in), optional :: amold - class(psb_c_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd end subroutine mld_c_hierarchy_bld end interface mld_hierarchy_bld diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index 25a6ba3c..6e8de542 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -88,18 +88,14 @@ module mld_d_prec_mod end interface mld_precbld interface mld_hierarchy_bld - subroutine mld_d_hierarchy_bld(a,desc_a,prec,info,amold,vmold,imold) + subroutine mld_d_hierarchy_bld(a,desc_a,prec,info) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & - & psb_d_base_sparse_mat, psb_d_base_vect_type, & - & psb_i_base_vect_type, mld_dprec_type, psb_ipk_ + & mld_dprec_type, psb_ipk_ implicit none type(psb_dspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_dprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info - class(psb_d_base_sparse_mat), intent(in), optional :: amold - class(psb_d_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd end subroutine mld_d_hierarchy_bld end interface mld_hierarchy_bld diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index da3d546d..b7b4ddc9 100644 --- a/mlprec/mld_s_prec_mod.f90 +++ b/mlprec/mld_s_prec_mod.f90 @@ -88,18 +88,14 @@ module mld_s_prec_mod end interface mld_precbld interface mld_hierarchy_bld - subroutine mld_s_hierarchy_bld(a,desc_a,prec,info,amold,vmold,imold) + subroutine mld_s_hierarchy_bld(a,desc_a,prec,info) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & - & psb_s_base_sparse_mat, psb_s_base_vect_type, & - & psb_i_base_vect_type, mld_sprec_type, psb_ipk_ + & mld_sprec_type, psb_ipk_ implicit none type(psb_sspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_sprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info - class(psb_s_base_sparse_mat), intent(in), optional :: amold - class(psb_s_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd end subroutine mld_s_hierarchy_bld end interface mld_hierarchy_bld diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index cd1aa321..1d2f203f 100644 --- a/mlprec/mld_z_prec_mod.f90 +++ b/mlprec/mld_z_prec_mod.f90 @@ -88,18 +88,14 @@ module mld_z_prec_mod end interface mld_precbld interface mld_hierarchy_bld - subroutine mld_z_hierarchy_bld(a,desc_a,prec,info,amold,vmold,imold) + subroutine mld_z_hierarchy_bld(a,desc_a,prec,info) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & - & psb_z_base_sparse_mat, psb_z_base_vect_type, & - & psb_i_base_vect_type, mld_zprec_type, psb_ipk_ + & mld_zprec_type, psb_ipk_ implicit none type(psb_zspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_zprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info - class(psb_z_base_sparse_mat), intent(in), optional :: amold - class(psb_z_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd end subroutine mld_z_hierarchy_bld end interface mld_hierarchy_bld From 84562c67f4e532bd3882f940b056c2313d7d74cc Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 3 Oct 2016 09:01:01 +0000 Subject: [PATCH 19/21] mld2p4-extaggr: mlprec/impl/mld_caggrmat_biz_asb.f90 mlprec/impl/mld_caggrmat_minnrg_asb.f90 mlprec/impl/mld_caggrmat_smth_asb.f90 mlprec/impl/mld_daggrmat_biz_asb.f90 mlprec/impl/mld_daggrmat_minnrg_asb.f90 mlprec/impl/mld_daggrmat_smth_asb.f90 mlprec/impl/mld_saggrmat_biz_asb.f90 mlprec/impl/mld_saggrmat_minnrg_asb.f90 mlprec/impl/mld_saggrmat_smth_asb.f90 mlprec/impl/mld_zaggrmat_biz_asb.f90 mlprec/impl/mld_zaggrmat_minnrg_asb.f90 mlprec/impl/mld_zaggrmat_smth_asb.f90 Use clean_zeros method in filtering. --- mlprec/impl/mld_caggrmat_biz_asb.f90 | 14 +------------- mlprec/impl/mld_caggrmat_minnrg_asb.f90 | 13 +------------ mlprec/impl/mld_caggrmat_smth_asb.f90 | 14 +------------- mlprec/impl/mld_daggrmat_biz_asb.f90 | 14 +------------- mlprec/impl/mld_daggrmat_minnrg_asb.f90 | 13 +------------ mlprec/impl/mld_daggrmat_smth_asb.f90 | 14 +------------- mlprec/impl/mld_saggrmat_biz_asb.f90 | 14 +------------- mlprec/impl/mld_saggrmat_minnrg_asb.f90 | 13 +------------ mlprec/impl/mld_saggrmat_smth_asb.f90 | 14 +------------- mlprec/impl/mld_zaggrmat_biz_asb.f90 | 14 +------------- mlprec/impl/mld_zaggrmat_minnrg_asb.f90 | 13 +------------ mlprec/impl/mld_zaggrmat_smth_asb.f90 | 14 +------------- 12 files changed, 12 insertions(+), 152 deletions(-) diff --git a/mlprec/impl/mld_caggrmat_biz_asb.f90 b/mlprec/impl/mld_caggrmat_biz_asb.f90 index 794bb9f1..d1ce58f9 100644 --- a/mlprec/impl/mld_caggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_caggrmat_biz_asb.f90 @@ -180,19 +180,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call tmpcoo%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) end if diff --git a/mlprec/impl/mld_caggrmat_minnrg_asb.f90 b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 index 4884252a..58e45cd6 100644 --- a/mlprec/impl/mld_caggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 @@ -299,18 +299,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) ! ! Build the smoothed prolongator using the filtered matrix diff --git a/mlprec/impl/mld_caggrmat_smth_asb.f90 b/mlprec/impl/mld_caggrmat_smth_asb.f90 index 83ad51ad..ed72e9ee 100644 --- a/mlprec/impl/mld_caggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_caggrmat_smth_asb.f90 @@ -199,19 +199,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call tmpcoo%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) end if diff --git a/mlprec/impl/mld_daggrmat_biz_asb.f90 b/mlprec/impl/mld_daggrmat_biz_asb.f90 index 3e7d2a8a..f65f16eb 100644 --- a/mlprec/impl/mld_daggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_daggrmat_biz_asb.f90 @@ -180,19 +180,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call tmpcoo%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) end if diff --git a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 index 965443ca..f54912d3 100644 --- a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 @@ -299,18 +299,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) ! ! Build the smoothed prolongator using the filtered matrix diff --git a/mlprec/impl/mld_daggrmat_smth_asb.f90 b/mlprec/impl/mld_daggrmat_smth_asb.f90 index 455a7f2a..390f5b71 100644 --- a/mlprec/impl/mld_daggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_daggrmat_smth_asb.f90 @@ -199,19 +199,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call tmpcoo%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) end if diff --git a/mlprec/impl/mld_saggrmat_biz_asb.f90 b/mlprec/impl/mld_saggrmat_biz_asb.f90 index f91c8102..946bb3eb 100644 --- a/mlprec/impl/mld_saggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_saggrmat_biz_asb.f90 @@ -180,19 +180,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call tmpcoo%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) end if diff --git a/mlprec/impl/mld_saggrmat_minnrg_asb.f90 b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 index 3868d9c6..defca9c0 100644 --- a/mlprec/impl/mld_saggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 @@ -299,18 +299,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) ! ! Build the smoothed prolongator using the filtered matrix diff --git a/mlprec/impl/mld_saggrmat_smth_asb.f90 b/mlprec/impl/mld_saggrmat_smth_asb.f90 index 03eb2155..4fc52ab2 100644 --- a/mlprec/impl/mld_saggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_saggrmat_smth_asb.f90 @@ -199,19 +199,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call tmpcoo%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) end if diff --git a/mlprec/impl/mld_zaggrmat_biz_asb.f90 b/mlprec/impl/mld_zaggrmat_biz_asb.f90 index 96b3f49f..a79f7c70 100644 --- a/mlprec/impl/mld_zaggrmat_biz_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_biz_asb.f90 @@ -180,19 +180,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call tmpcoo%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) end if diff --git a/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 index 80143f4d..1e52efd5 100644 --- a/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 @@ -299,18 +299,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) ! ! Build the smoothed prolongator using the filtered matrix diff --git a/mlprec/impl/mld_zaggrmat_smth_asb.f90 b/mlprec/impl/mld_zaggrmat_smth_asb.f90 index 8e85e14e..0f632736 100644 --- a/mlprec/impl/mld_zaggrmat_smth_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_smth_asb.f90 @@ -199,19 +199,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(tmpcoo,info) - k = 0 - do j=1,tmpcoo%get_nzeros() - if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then - k = k + 1 - tmpcoo%val(k) = tmpcoo%val(j) - tmpcoo%ia(k) = tmpcoo%ia(j) - tmpcoo%ja(k) = tmpcoo%ja(j) - end if - end do - call tmpcoo%set_nzeros(k) - call tmpcoo%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(tmpcoo,info) + call acsrf%clean_zeros(info) end if From 3e0040218adbd7dcc99df41d12559748a10d740a Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 3 Oct 2016 15:03:31 +0000 Subject: [PATCH 20/21] mld2p4-extaggr: mlprec/impl/mld_c_hierarchy_bld.f90 mlprec/impl/mld_ccprecset.F90 mlprec/impl/mld_cprecset.F90 mlprec/impl/mld_d_hierarchy_bld.f90 mlprec/impl/mld_dcprecset.F90 mlprec/impl/mld_dprecset.F90 mlprec/impl/mld_s_hierarchy_bld.f90 mlprec/impl/mld_scprecset.F90 mlprec/impl/mld_sprecset.F90 mlprec/impl/mld_z_hierarchy_bld.f90 mlprec/impl/mld_zcprecset.F90 mlprec/impl/mld_zprecset.F90 Added back SCALE in precset. Fixed hierarchy buildup. --- mlprec/impl/mld_c_hierarchy_bld.f90 | 126 +++++++++++++++++++--------- mlprec/impl/mld_ccprecset.F90 | 5 ++ mlprec/impl/mld_cprecset.F90 | 5 ++ mlprec/impl/mld_d_hierarchy_bld.f90 | 126 +++++++++++++++++++--------- mlprec/impl/mld_dcprecset.F90 | 5 ++ mlprec/impl/mld_dprecset.F90 | 5 ++ mlprec/impl/mld_s_hierarchy_bld.f90 | 126 +++++++++++++++++++--------- mlprec/impl/mld_scprecset.F90 | 5 ++ mlprec/impl/mld_sprecset.F90 | 5 ++ mlprec/impl/mld_z_hierarchy_bld.f90 | 126 +++++++++++++++++++--------- mlprec/impl/mld_zcprecset.F90 | 5 ++ mlprec/impl/mld_zprecset.F90 | 5 ++ 12 files changed, 388 insertions(+), 156 deletions(-) diff --git a/mlprec/impl/mld_c_hierarchy_bld.f90 b/mlprec/impl/mld_c_hierarchy_bld.f90 index bad8ba82..836a6905 100644 --- a/mlprec/impl/mld_c_hierarchy_bld.f90 +++ b/mlprec/impl/mld_c_hierarchy_bld.f90 @@ -82,7 +82,7 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info) integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize real(psb_spk_) :: mnaggratio, sizeratio - class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2 type(mld_sml_parms) :: baseparms, medparms, coarseparms integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) type(psb_cspmat_type) :: op_prol @@ -215,50 +215,40 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info) 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) + call save_smoothers(p%precv(iszv),coarse_sm,coarse_sm2,info) + if (info == 0) call save_smoothers(p%precv(2),med_sm,med_sm2,info) + if (info == 0) call save_smoothers(p%precv(1),base_sm,base_sm2,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 - ! ! First set desired number of levels ! if (iszv /= nplevs) then allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif + ! First all existing levels + if (info == 0) tprecv(1)%parms = baseparms + if (info == 0) call restore_smoothers(tprecv(1),p%precv(1)%sm,p%precv(1)%sm2a,info) + do i=2, min(iszv,nplevs) - 1 + if (info == 0) tprecv(i)%parms = medparms + if (info == 0) call restore_smoothers(tprecv(i),p%precv(i)%sm,p%precv(i)%sm2a,info) + end do + ! Further intermediates, if any + do i=iszv-1, nplevs - 1 + if (info == 0) tprecv(i)%parms = medparms + if (info == 0) call restore_smoothers(tprecv(i),med_sm,med_sm2,info) end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,stat=info) + ! Then coarse + if (info == 0) tprecv(nplevs)%parms = coarseparms + if (info == 0) call restore_smoothers(tprecv(nplevs),coarse_sm,coarse_sm2,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='prec reallocation') goto 9999 endif + do i=1,iszv call p%precv(i)%free(info) end do @@ -330,7 +320,7 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info) ! ! We are not gaining ! - newsz = newsz-1 + newsz = i-1 end if end if @@ -350,20 +340,25 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info) end if end if call psb_bcast(ictxt,newsz) - if (newsz > 0) & - & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) - - if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& - & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& - & ilaggr,nlaggr,op_prol,info) - + if (newsz > 0) then + if (info == 0) p%precv(newsz)%parms = coarseparms + if (info == 0) call restore_smoothers(p%precv(newsz),coarse_sm,coarse_sm2,info) + + if (info == psb_success_) call mld_lev_mat_asb(p%precv(newsz),& + & p%precv(newsz-1)%base_a,p%precv(newsz-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + exit array_build_loop + else + if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Map build') goto 9999 endif - if (newsz > 0) exit array_build_loop end do array_build_loop if (newsz > 0) then @@ -399,7 +394,6 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info) end do end if - if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) @@ -419,4 +413,58 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info) return +contains + subroutine save_smoothers(level,save1, save2,info) + type(mld_c_onelev_type), intent(in) :: level + class(mld_c_base_smoother_type), allocatable , intent(inout) :: save1, save2 + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(save1)) then + call save1%free(info) + if (info == 0) deallocate(save1,stat=info) + if (info /= 0) return + end if + if (allocated(save2)) then + call save2%free(info) + if (info == 0) deallocate(save2,stat=info) + if (info /= 0) return + end if + allocate(save1, source=level%sm,stat=info) + if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info) + + return + end subroutine save_smoothers + + subroutine restore_smoothers(level,save1, save2,info) + type(mld_c_onelev_type), intent(inout), target :: level + class(mld_c_base_smoother_type), allocatable, intent(in) :: save1, save2 + integer(psb_ipk_), intent(out) :: info + + info = 0 + + if (allocated(level%sm)) then + if (info == 0) call level%sm%free(info) + if (info == 0) deallocate(level%sm,stat=info) + end if + if (allocated(save1)) then + if (info == 0) allocate(level%sm,source=save1,stat=info) + end if + + if (info /= 0) return + + if (allocated(level%sm2a)) then + if (info == 0) call level%sm2a%free(info) + if (info == 0) deallocate(level%sm2a,stat=info) + end if + if (allocated(save2)) then + if (info == 0) allocate(level%sm2a,source=save2,stat=info) + if (info == 0) level%sm2 => level%sm2a + else + if (allocated(level%sm)) level%sm2 => level%sm + end if + + return + end subroutine restore_smoothers + end subroutine mld_c_hierarchy_bld diff --git a/mlprec/impl/mld_ccprecset.F90 b/mlprec/impl/mld_ccprecset.F90 index 783b4582..8c39848f 100644 --- a/mlprec/impl/mld_ccprecset.F90 +++ b/mlprec/impl/mld_ccprecset.F90 @@ -519,6 +519,11 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev,pos) ilev_=nlev_ call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) + case('AGGR_SCALE') + do ilev_ = 2, nlev_ + call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos) + end do + case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ diff --git a/mlprec/impl/mld_cprecset.F90 b/mlprec/impl/mld_cprecset.F90 index 38c1d791..02f32538 100644 --- a/mlprec/impl/mld_cprecset.F90 +++ b/mlprec/impl/mld_cprecset.F90 @@ -621,6 +621,11 @@ subroutine mld_cprecsetr(p,what,val,info,ilev,pos) ilev_=nlev_ call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) + case(mld_aggr_scale_) + do ilev_ = 2, nlev_ + call p%precv(ilev_)%set(mld_aggr_scale_,val,info,pos=pos) + end do + case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ diff --git a/mlprec/impl/mld_d_hierarchy_bld.f90 b/mlprec/impl/mld_d_hierarchy_bld.f90 index e8af7fed..c6061345 100644 --- a/mlprec/impl/mld_d_hierarchy_bld.f90 +++ b/mlprec/impl/mld_d_hierarchy_bld.f90 @@ -82,7 +82,7 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info) integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize real(psb_dpk_) :: mnaggratio, sizeratio - class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2 type(mld_dml_parms) :: baseparms, medparms, coarseparms integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) type(psb_dspmat_type) :: op_prol @@ -215,50 +215,40 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info) 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) + call save_smoothers(p%precv(iszv),coarse_sm,coarse_sm2,info) + if (info == 0) call save_smoothers(p%precv(2),med_sm,med_sm2,info) + if (info == 0) call save_smoothers(p%precv(1),base_sm,base_sm2,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 - ! ! First set desired number of levels ! if (iszv /= nplevs) then allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif + ! First all existing levels + if (info == 0) tprecv(1)%parms = baseparms + if (info == 0) call restore_smoothers(tprecv(1),p%precv(1)%sm,p%precv(1)%sm2a,info) + do i=2, min(iszv,nplevs) - 1 + if (info == 0) tprecv(i)%parms = medparms + if (info == 0) call restore_smoothers(tprecv(i),p%precv(i)%sm,p%precv(i)%sm2a,info) + end do + ! Further intermediates, if any + do i=iszv-1, nplevs - 1 + if (info == 0) tprecv(i)%parms = medparms + if (info == 0) call restore_smoothers(tprecv(i),med_sm,med_sm2,info) end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,stat=info) + ! Then coarse + if (info == 0) tprecv(nplevs)%parms = coarseparms + if (info == 0) call restore_smoothers(tprecv(nplevs),coarse_sm,coarse_sm2,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='prec reallocation') goto 9999 endif + do i=1,iszv call p%precv(i)%free(info) end do @@ -330,7 +320,7 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info) ! ! We are not gaining ! - newsz = newsz-1 + newsz = i-1 end if end if @@ -350,20 +340,25 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info) end if end if call psb_bcast(ictxt,newsz) - if (newsz > 0) & - & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) - - if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& - & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& - & ilaggr,nlaggr,op_prol,info) - + if (newsz > 0) then + if (info == 0) p%precv(newsz)%parms = coarseparms + if (info == 0) call restore_smoothers(p%precv(newsz),coarse_sm,coarse_sm2,info) + + if (info == psb_success_) call mld_lev_mat_asb(p%precv(newsz),& + & p%precv(newsz-1)%base_a,p%precv(newsz-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + exit array_build_loop + else + if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Map build') goto 9999 endif - if (newsz > 0) exit array_build_loop end do array_build_loop if (newsz > 0) then @@ -399,7 +394,6 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info) end do end if - if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) @@ -419,4 +413,58 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info) return +contains + subroutine save_smoothers(level,save1, save2,info) + type(mld_d_onelev_type), intent(in) :: level + class(mld_d_base_smoother_type), allocatable , intent(inout) :: save1, save2 + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(save1)) then + call save1%free(info) + if (info == 0) deallocate(save1,stat=info) + if (info /= 0) return + end if + if (allocated(save2)) then + call save2%free(info) + if (info == 0) deallocate(save2,stat=info) + if (info /= 0) return + end if + allocate(save1, source=level%sm,stat=info) + if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info) + + return + end subroutine save_smoothers + + subroutine restore_smoothers(level,save1, save2,info) + type(mld_d_onelev_type), intent(inout), target :: level + class(mld_d_base_smoother_type), allocatable, intent(in) :: save1, save2 + integer(psb_ipk_), intent(out) :: info + + info = 0 + + if (allocated(level%sm)) then + if (info == 0) call level%sm%free(info) + if (info == 0) deallocate(level%sm,stat=info) + end if + if (allocated(save1)) then + if (info == 0) allocate(level%sm,source=save1,stat=info) + end if + + if (info /= 0) return + + if (allocated(level%sm2a)) then + if (info == 0) call level%sm2a%free(info) + if (info == 0) deallocate(level%sm2a,stat=info) + end if + if (allocated(save2)) then + if (info == 0) allocate(level%sm2a,source=save2,stat=info) + if (info == 0) level%sm2 => level%sm2a + else + if (allocated(level%sm)) level%sm2 => level%sm + end if + + return + end subroutine restore_smoothers + end subroutine mld_d_hierarchy_bld diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index bb61822a..005ecbba 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -529,6 +529,11 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev,pos) ilev_=nlev_ call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) + case('AGGR_SCALE') + do ilev_ = 2, nlev_ + call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos) + end do + case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 37236b03..6d868885 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -631,6 +631,11 @@ subroutine mld_dprecsetr(p,what,val,info,ilev,pos) ilev_=nlev_ call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) + case(mld_aggr_scale_) + do ilev_ = 2, nlev_ + call p%precv(ilev_)%set(mld_aggr_scale_,val,info,pos=pos) + end do + case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ diff --git a/mlprec/impl/mld_s_hierarchy_bld.f90 b/mlprec/impl/mld_s_hierarchy_bld.f90 index acd8aa53..b6c1f269 100644 --- a/mlprec/impl/mld_s_hierarchy_bld.f90 +++ b/mlprec/impl/mld_s_hierarchy_bld.f90 @@ -82,7 +82,7 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info) integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize real(psb_spk_) :: mnaggratio, sizeratio - class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2 type(mld_sml_parms) :: baseparms, medparms, coarseparms integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) type(psb_sspmat_type) :: op_prol @@ -215,50 +215,40 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info) 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) + call save_smoothers(p%precv(iszv),coarse_sm,coarse_sm2,info) + if (info == 0) call save_smoothers(p%precv(2),med_sm,med_sm2,info) + if (info == 0) call save_smoothers(p%precv(1),base_sm,base_sm2,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 - ! ! First set desired number of levels ! if (iszv /= nplevs) then allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif + ! First all existing levels + if (info == 0) tprecv(1)%parms = baseparms + if (info == 0) call restore_smoothers(tprecv(1),p%precv(1)%sm,p%precv(1)%sm2a,info) + do i=2, min(iszv,nplevs) - 1 + if (info == 0) tprecv(i)%parms = medparms + if (info == 0) call restore_smoothers(tprecv(i),p%precv(i)%sm,p%precv(i)%sm2a,info) + end do + ! Further intermediates, if any + do i=iszv-1, nplevs - 1 + if (info == 0) tprecv(i)%parms = medparms + if (info == 0) call restore_smoothers(tprecv(i),med_sm,med_sm2,info) end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,stat=info) + ! Then coarse + if (info == 0) tprecv(nplevs)%parms = coarseparms + if (info == 0) call restore_smoothers(tprecv(nplevs),coarse_sm,coarse_sm2,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='prec reallocation') goto 9999 endif + do i=1,iszv call p%precv(i)%free(info) end do @@ -330,7 +320,7 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info) ! ! We are not gaining ! - newsz = newsz-1 + newsz = i-1 end if end if @@ -350,20 +340,25 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info) end if end if call psb_bcast(ictxt,newsz) - if (newsz > 0) & - & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) - - if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& - & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& - & ilaggr,nlaggr,op_prol,info) - + if (newsz > 0) then + if (info == 0) p%precv(newsz)%parms = coarseparms + if (info == 0) call restore_smoothers(p%precv(newsz),coarse_sm,coarse_sm2,info) + + if (info == psb_success_) call mld_lev_mat_asb(p%precv(newsz),& + & p%precv(newsz-1)%base_a,p%precv(newsz-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + exit array_build_loop + else + if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Map build') goto 9999 endif - if (newsz > 0) exit array_build_loop end do array_build_loop if (newsz > 0) then @@ -399,7 +394,6 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info) end do end if - if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) @@ -419,4 +413,58 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info) return +contains + subroutine save_smoothers(level,save1, save2,info) + type(mld_s_onelev_type), intent(in) :: level + class(mld_s_base_smoother_type), allocatable , intent(inout) :: save1, save2 + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(save1)) then + call save1%free(info) + if (info == 0) deallocate(save1,stat=info) + if (info /= 0) return + end if + if (allocated(save2)) then + call save2%free(info) + if (info == 0) deallocate(save2,stat=info) + if (info /= 0) return + end if + allocate(save1, source=level%sm,stat=info) + if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info) + + return + end subroutine save_smoothers + + subroutine restore_smoothers(level,save1, save2,info) + type(mld_s_onelev_type), intent(inout), target :: level + class(mld_s_base_smoother_type), allocatable, intent(in) :: save1, save2 + integer(psb_ipk_), intent(out) :: info + + info = 0 + + if (allocated(level%sm)) then + if (info == 0) call level%sm%free(info) + if (info == 0) deallocate(level%sm,stat=info) + end if + if (allocated(save1)) then + if (info == 0) allocate(level%sm,source=save1,stat=info) + end if + + if (info /= 0) return + + if (allocated(level%sm2a)) then + if (info == 0) call level%sm2a%free(info) + if (info == 0) deallocate(level%sm2a,stat=info) + end if + if (allocated(save2)) then + if (info == 0) allocate(level%sm2a,source=save2,stat=info) + if (info == 0) level%sm2 => level%sm2a + else + if (allocated(level%sm)) level%sm2 => level%sm + end if + + return + end subroutine restore_smoothers + end subroutine mld_s_hierarchy_bld diff --git a/mlprec/impl/mld_scprecset.F90 b/mlprec/impl/mld_scprecset.F90 index af641414..ae70a83b 100644 --- a/mlprec/impl/mld_scprecset.F90 +++ b/mlprec/impl/mld_scprecset.F90 @@ -519,6 +519,11 @@ subroutine mld_scprecsetr(p,what,val,info,ilev,pos) ilev_=nlev_ call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) + case('AGGR_SCALE') + do ilev_ = 2, nlev_ + call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos) + end do + case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ diff --git a/mlprec/impl/mld_sprecset.F90 b/mlprec/impl/mld_sprecset.F90 index a8b5c289..4bc463ca 100644 --- a/mlprec/impl/mld_sprecset.F90 +++ b/mlprec/impl/mld_sprecset.F90 @@ -621,6 +621,11 @@ subroutine mld_sprecsetr(p,what,val,info,ilev,pos) ilev_=nlev_ call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) + case(mld_aggr_scale_) + do ilev_ = 2, nlev_ + call p%precv(ilev_)%set(mld_aggr_scale_,val,info,pos=pos) + end do + case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ diff --git a/mlprec/impl/mld_z_hierarchy_bld.f90 b/mlprec/impl/mld_z_hierarchy_bld.f90 index 33982c77..6b6a306e 100644 --- a/mlprec/impl/mld_z_hierarchy_bld.f90 +++ b/mlprec/impl/mld_z_hierarchy_bld.f90 @@ -82,7 +82,7 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info) integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize real(psb_dpk_) :: mnaggratio, sizeratio - class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2 type(mld_dml_parms) :: baseparms, medparms, coarseparms integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) type(psb_zspmat_type) :: op_prol @@ -215,50 +215,40 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info) 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) + call save_smoothers(p%precv(iszv),coarse_sm,coarse_sm2,info) + if (info == 0) call save_smoothers(p%precv(2),med_sm,med_sm2,info) + if (info == 0) call save_smoothers(p%precv(1),base_sm,base_sm2,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 - ! ! First set desired number of levels ! if (iszv /= nplevs) then allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif + ! First all existing levels + if (info == 0) tprecv(1)%parms = baseparms + if (info == 0) call restore_smoothers(tprecv(1),p%precv(1)%sm,p%precv(1)%sm2a,info) + do i=2, min(iszv,nplevs) - 1 + if (info == 0) tprecv(i)%parms = medparms + if (info == 0) call restore_smoothers(tprecv(i),p%precv(i)%sm,p%precv(i)%sm2a,info) + end do + ! Further intermediates, if any + do i=iszv-1, nplevs - 1 + if (info == 0) tprecv(i)%parms = medparms + if (info == 0) call restore_smoothers(tprecv(i),med_sm,med_sm2,info) end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,stat=info) + ! Then coarse + if (info == 0) tprecv(nplevs)%parms = coarseparms + if (info == 0) call restore_smoothers(tprecv(nplevs),coarse_sm,coarse_sm2,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='prec reallocation') goto 9999 endif + do i=1,iszv call p%precv(i)%free(info) end do @@ -330,7 +320,7 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info) ! ! We are not gaining ! - newsz = newsz-1 + newsz = i-1 end if end if @@ -350,20 +340,25 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info) end if end if call psb_bcast(ictxt,newsz) - if (newsz > 0) & - & call p%precv(i)%parms%get_coarse(p%precv(iszv)%parms) - - if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& - & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& - & ilaggr,nlaggr,op_prol,info) - + if (newsz > 0) then + if (info == 0) p%precv(newsz)%parms = coarseparms + if (info == 0) call restore_smoothers(p%precv(newsz),coarse_sm,coarse_sm2,info) + + if (info == psb_success_) call mld_lev_mat_asb(p%precv(newsz),& + & p%precv(newsz-1)%base_a,p%precv(newsz-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + exit array_build_loop + else + if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),& + & p%precv(i-1)%base_a,p%precv(i-1)%base_desc,& + & ilaggr,nlaggr,op_prol,info) + end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Map build') goto 9999 endif - if (newsz > 0) exit array_build_loop end do array_build_loop if (newsz > 0) then @@ -399,7 +394,6 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info) end do end if - if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) @@ -419,4 +413,58 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info) return +contains + subroutine save_smoothers(level,save1, save2,info) + type(mld_z_onelev_type), intent(in) :: level + class(mld_z_base_smoother_type), allocatable , intent(inout) :: save1, save2 + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(save1)) then + call save1%free(info) + if (info == 0) deallocate(save1,stat=info) + if (info /= 0) return + end if + if (allocated(save2)) then + call save2%free(info) + if (info == 0) deallocate(save2,stat=info) + if (info /= 0) return + end if + allocate(save1, source=level%sm,stat=info) + if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info) + + return + end subroutine save_smoothers + + subroutine restore_smoothers(level,save1, save2,info) + type(mld_z_onelev_type), intent(inout), target :: level + class(mld_z_base_smoother_type), allocatable, intent(in) :: save1, save2 + integer(psb_ipk_), intent(out) :: info + + info = 0 + + if (allocated(level%sm)) then + if (info == 0) call level%sm%free(info) + if (info == 0) deallocate(level%sm,stat=info) + end if + if (allocated(save1)) then + if (info == 0) allocate(level%sm,source=save1,stat=info) + end if + + if (info /= 0) return + + if (allocated(level%sm2a)) then + if (info == 0) call level%sm2a%free(info) + if (info == 0) deallocate(level%sm2a,stat=info) + end if + if (allocated(save2)) then + if (info == 0) allocate(level%sm2a,source=save2,stat=info) + if (info == 0) level%sm2 => level%sm2a + else + if (allocated(level%sm)) level%sm2 => level%sm + end if + + return + end subroutine restore_smoothers + end subroutine mld_z_hierarchy_bld diff --git a/mlprec/impl/mld_zcprecset.F90 b/mlprec/impl/mld_zcprecset.F90 index 338616fb..abdd925b 100644 --- a/mlprec/impl/mld_zcprecset.F90 +++ b/mlprec/impl/mld_zcprecset.F90 @@ -529,6 +529,11 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev,pos) ilev_=nlev_ call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) + case('AGGR_SCALE') + do ilev_ = 2, nlev_ + call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos) + end do + case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ diff --git a/mlprec/impl/mld_zprecset.F90 b/mlprec/impl/mld_zprecset.F90 index e57c4c38..ab1a3f9c 100644 --- a/mlprec/impl/mld_zprecset.F90 +++ b/mlprec/impl/mld_zprecset.F90 @@ -631,6 +631,11 @@ subroutine mld_zprecsetr(p,what,val,info,ilev,pos) ilev_=nlev_ call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) + case(mld_aggr_scale_) + do ilev_ = 2, nlev_ + call p%precv(ilev_)%set(mld_aggr_scale_,val,info,pos=pos) + end do + case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ From bc8ba9bb8a303274313b520fd1070e0e2453397c Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 3 Oct 2016 15:55:51 +0000 Subject: [PATCH 21/21] mld2p4-extaggr: mlprec/impl/Makefile mlprec/impl/mld_c_ml_prec_bld.f90 mlprec/impl/mld_c_smoothers_bld.f90 mlprec/impl/mld_cmlprec_bld.f90 mlprec/impl/mld_d_ml_prec_bld.f90 mlprec/impl/mld_d_smoothers_bld.f90 mlprec/impl/mld_dmlprec_bld.f90 mlprec/impl/mld_s_ml_prec_bld.f90 mlprec/impl/mld_s_smoothers_bld.f90 mlprec/impl/mld_smlprec_bld.f90 mlprec/impl/mld_z_ml_prec_bld.f90 mlprec/impl/mld_z_smoothers_bld.f90 mlprec/impl/mld_zmlprec_bld.f90 mlprec/mld_c_inner_mod.f90 mlprec/mld_c_prec_mod.f90 mlprec/mld_d_inner_mod.f90 mlprec/mld_d_prec_mod.f90 mlprec/mld_s_inner_mod.f90 mlprec/mld_s_prec_mod.f90 mlprec/mld_z_inner_mod.f90 mlprec/mld_z_prec_mod.f90 Revised naming. --- mlprec/impl/Makefile | 8 ++++---- ..._c_ml_prec_bld.f90 => mld_c_smoothers_bld.f90} | 12 ++++++------ mlprec/impl/mld_cmlprec_bld.f90 | 2 +- ..._d_ml_prec_bld.f90 => mld_d_smoothers_bld.f90} | 12 ++++++------ mlprec/impl/mld_dmlprec_bld.f90 | 2 +- ..._s_ml_prec_bld.f90 => mld_s_smoothers_bld.f90} | 12 ++++++------ mlprec/impl/mld_smlprec_bld.f90 | 2 +- ..._z_ml_prec_bld.f90 => mld_z_smoothers_bld.f90} | 12 ++++++------ mlprec/impl/mld_zmlprec_bld.f90 | 2 +- mlprec/mld_c_inner_mod.f90 | 15 --------------- mlprec/mld_c_prec_mod.f90 | 8 ++++---- mlprec/mld_d_inner_mod.f90 | 15 --------------- mlprec/mld_d_prec_mod.f90 | 8 ++++---- mlprec/mld_s_inner_mod.f90 | 15 --------------- mlprec/mld_s_prec_mod.f90 | 8 ++++---- mlprec/mld_z_inner_mod.f90 | 15 --------------- mlprec/mld_z_prec_mod.f90 | 8 ++++---- 17 files changed, 48 insertions(+), 108 deletions(-) rename mlprec/impl/{mld_c_ml_prec_bld.f90 => mld_c_smoothers_bld.f90} (96%) rename mlprec/impl/{mld_d_ml_prec_bld.f90 => mld_d_smoothers_bld.f90} (96%) rename mlprec/impl/{mld_s_ml_prec_bld.f90 => mld_s_smoothers_bld.f90} (96%) rename mlprec/impl/{mld_z_ml_prec_bld.f90 => mld_z_smoothers_bld.f90} (96%) diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index e03c55fc..9d4070ee 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -23,25 +23,25 @@ MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zs DINNEROBJS= mld_dmlprec_bld.o \ - mld_d_ml_prec_bld.o mld_d_hierarchy_bld.o \ + mld_d_smoothers_bld.o mld_d_hierarchy_bld.o \ mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \ mld_d_dec_map_bld.o mld_dmlprec_aply.o mld_daggrmat_asb.o \ $(DMPFOBJS) mld_d_extprol_bld.o mld_d_lev_aggrmap_bld.o mld_d_lev_aggrmat_asb.o SINNEROBJS= mld_smlprec_bld.o \ - mld_s_ml_prec_bld.o mld_s_hierarchy_bld.o \ + mld_s_smoothers_bld.o mld_s_hierarchy_bld.o \ mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o mld_saggrmap_bld.o \ mld_s_dec_map_bld.o mld_smlprec_aply.o mld_saggrmat_asb.o \ $(SMPFOBJS) mld_s_extprol_bld.o mld_s_lev_aggrmap_bld.o mld_s_lev_aggrmat_asb.o ZINNEROBJS= mld_zmlprec_bld.o \ - mld_z_ml_prec_bld.o mld_z_hierarchy_bld.o \ + mld_z_smoothers_bld.o mld_z_hierarchy_bld.o \ mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \ mld_z_dec_map_bld.o mld_zmlprec_aply.o mld_zaggrmat_asb.o \ $(ZMPFOBJS) mld_z_extprol_bld.o mld_z_lev_aggrmap_bld.o mld_z_lev_aggrmat_asb.o CINNEROBJS= mld_cmlprec_bld.o \ - mld_c_ml_prec_bld.o mld_c_hierarchy_bld.o \ + mld_c_smoothers_bld.o mld_c_hierarchy_bld.o \ mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \ mld_c_dec_map_bld.o mld_cmlprec_aply.o mld_caggrmat_asb.o \ $(CMPFOBJS) mld_c_extprol_bld.o mld_c_lev_aggrmap_bld.o mld_c_lev_aggrmat_asb.o diff --git a/mlprec/impl/mld_c_ml_prec_bld.f90 b/mlprec/impl/mld_c_smoothers_bld.f90 similarity index 96% rename from mlprec/impl/mld_c_ml_prec_bld.f90 rename to mlprec/impl/mld_c_smoothers_bld.f90 index bb875722..4a8815b2 100644 --- a/mlprec/impl/mld_c_ml_prec_bld.f90 +++ b/mlprec/impl/mld_c_smoothers_bld.f90 @@ -36,9 +36,9 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -! File: mld_c_ml_prec_bld.f90 +! File: mld_c_smoothers_bld.f90 ! -! Subroutine: mld_c_ml_prec_bld +! Subroutine: mld_c_smoothers_bld ! Version: complex ! ! This routine builds the preconditioner according to the requirements made by @@ -74,11 +74,11 @@ ! ! ! -subroutine mld_c_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_c_smoothers_bld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_c_inner_mod - use mld_c_prec_mod, mld_protect_name => mld_c_ml_prec_bld + use mld_c_prec_mod, mld_protect_name => mld_c_smoothers_bld Implicit None @@ -109,7 +109,7 @@ subroutine mld_c_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - name = 'mld_c_ml_prec_bld' + name = 'mld_c_smoothers_bld' info = psb_success_ int_err(1) = 0 ictxt = desc_a%get_context() @@ -191,4 +191,4 @@ subroutine mld_c_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) return -end subroutine mld_c_ml_prec_bld +end subroutine mld_c_smoothers_bld diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index d3ef5b41..ba53ea68 100644 --- a/mlprec/impl/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -129,7 +129,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold) iszv = p%get_nlevs() - call mld_c_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_c_smoothers_bld(a,desc_a,p,info,amold,vmold,imold) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_d_ml_prec_bld.f90 b/mlprec/impl/mld_d_smoothers_bld.f90 similarity index 96% rename from mlprec/impl/mld_d_ml_prec_bld.f90 rename to mlprec/impl/mld_d_smoothers_bld.f90 index f2507278..f0e3ad2d 100644 --- a/mlprec/impl/mld_d_ml_prec_bld.f90 +++ b/mlprec/impl/mld_d_smoothers_bld.f90 @@ -36,9 +36,9 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -! File: mld_d_ml_prec_bld.f90 +! File: mld_d_smoothers_bld.f90 ! -! Subroutine: mld_d_ml_prec_bld +! Subroutine: mld_d_smoothers_bld ! Version: real ! ! This routine builds the preconditioner according to the requirements made by @@ -74,11 +74,11 @@ ! ! ! -subroutine mld_d_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_d_smoothers_bld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_d_inner_mod - use mld_d_prec_mod, mld_protect_name => mld_d_ml_prec_bld + use mld_d_prec_mod, mld_protect_name => mld_d_smoothers_bld Implicit None @@ -109,7 +109,7 @@ subroutine mld_d_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - name = 'mld_d_ml_prec_bld' + name = 'mld_d_smoothers_bld' info = psb_success_ int_err(1) = 0 ictxt = desc_a%get_context() @@ -191,4 +191,4 @@ subroutine mld_d_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) return -end subroutine mld_d_ml_prec_bld +end subroutine mld_d_smoothers_bld diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index b5252739..9fbe1c70 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -129,7 +129,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold) iszv = p%get_nlevs() - call mld_d_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_d_smoothers_bld(a,desc_a,p,info,amold,vmold,imold) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_s_ml_prec_bld.f90 b/mlprec/impl/mld_s_smoothers_bld.f90 similarity index 96% rename from mlprec/impl/mld_s_ml_prec_bld.f90 rename to mlprec/impl/mld_s_smoothers_bld.f90 index 3614504d..4561a5f7 100644 --- a/mlprec/impl/mld_s_ml_prec_bld.f90 +++ b/mlprec/impl/mld_s_smoothers_bld.f90 @@ -36,9 +36,9 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -! File: mld_s_ml_prec_bld.f90 +! File: mld_s_smoothers_bld.f90 ! -! Subroutine: mld_s_ml_prec_bld +! Subroutine: mld_s_smoothers_bld ! Version: real ! ! This routine builds the preconditioner according to the requirements made by @@ -74,11 +74,11 @@ ! ! ! -subroutine mld_s_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_s_smoothers_bld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_s_inner_mod - use mld_s_prec_mod, mld_protect_name => mld_s_ml_prec_bld + use mld_s_prec_mod, mld_protect_name => mld_s_smoothers_bld Implicit None @@ -109,7 +109,7 @@ subroutine mld_s_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - name = 'mld_s_ml_prec_bld' + name = 'mld_s_smoothers_bld' info = psb_success_ int_err(1) = 0 ictxt = desc_a%get_context() @@ -191,4 +191,4 @@ subroutine mld_s_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) return -end subroutine mld_s_ml_prec_bld +end subroutine mld_s_smoothers_bld diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index b96dc733..761df534 100644 --- a/mlprec/impl/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -129,7 +129,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold) iszv = p%get_nlevs() - call mld_s_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_s_smoothers_bld(a,desc_a,p,info,amold,vmold,imold) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_z_ml_prec_bld.f90 b/mlprec/impl/mld_z_smoothers_bld.f90 similarity index 96% rename from mlprec/impl/mld_z_ml_prec_bld.f90 rename to mlprec/impl/mld_z_smoothers_bld.f90 index 6a87f734..20f1f1b9 100644 --- a/mlprec/impl/mld_z_ml_prec_bld.f90 +++ b/mlprec/impl/mld_z_smoothers_bld.f90 @@ -36,9 +36,9 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -! File: mld_z_ml_prec_bld.f90 +! File: mld_z_smoothers_bld.f90 ! -! Subroutine: mld_z_ml_prec_bld +! Subroutine: mld_z_smoothers_bld ! Version: complex ! ! This routine builds the preconditioner according to the requirements made by @@ -74,11 +74,11 @@ ! ! ! -subroutine mld_z_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_z_smoothers_bld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_z_inner_mod - use mld_z_prec_mod, mld_protect_name => mld_z_ml_prec_bld + use mld_z_prec_mod, mld_protect_name => mld_z_smoothers_bld Implicit None @@ -109,7 +109,7 @@ subroutine mld_z_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - name = 'mld_z_ml_prec_bld' + name = 'mld_z_smoothers_bld' info = psb_success_ int_err(1) = 0 ictxt = desc_a%get_context() @@ -191,4 +191,4 @@ subroutine mld_z_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) return -end subroutine mld_z_ml_prec_bld +end subroutine mld_z_smoothers_bld diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index 7c292b1c..50253ac9 100644 --- a/mlprec/impl/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -129,7 +129,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold) iszv = p%get_nlevs() - call mld_z_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_z_smoothers_bld(a,desc_a,p,info,amold,vmold,imold) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 467a193c..bf447a14 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -64,7 +64,6 @@ module mld_c_inner_mod end subroutine mld_cmlprec_bld end interface mld_mlprec_bld - interface mld_mlprec_aply subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_ @@ -95,20 +94,6 @@ module mld_c_inner_mod end subroutine mld_cmlprec_aply_vect end interface mld_mlprec_aply - - interface mld_coarse_bld - subroutine mld_ccoarse_bld(a,desc_a,p,info) - use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_ - use mld_c_prec_type, only : mld_c_onelev_type - implicit none - type(psb_cspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - type(mld_c_onelev_type), intent(inout), target :: p - integer(psb_ipk_), intent(out) :: info - end subroutine mld_ccoarse_bld - end interface mld_coarse_bld - - interface mld_bld_mlhier_aggsize subroutine mld_c_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type,psb_spk_ diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index 103d66c5..7a0e06cb 100644 --- a/mlprec/mld_c_prec_mod.f90 +++ b/mlprec/mld_c_prec_mod.f90 @@ -120,8 +120,8 @@ module mld_c_prec_mod end subroutine mld_c_extprol_bld end interface mld_extprol_bld - interface mld_ml_prec_bld - subroutine mld_c_ml_prec_bld(a,desc_a,prec,info,amold,vmold,imold) + interface mld_smoothers_bld + subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & psb_c_base_sparse_mat, psb_c_base_vect_type, & & psb_i_base_vect_type, mld_cprec_type, psb_ipk_ @@ -134,8 +134,8 @@ module mld_c_prec_mod class(psb_c_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd - end subroutine mld_c_ml_prec_bld - end interface mld_ml_prec_bld + end subroutine mld_c_smoothers_bld + end interface mld_smoothers_bld contains diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index 6fc4c07a..cd4dd596 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -64,7 +64,6 @@ module mld_d_inner_mod end subroutine mld_dmlprec_bld end interface mld_mlprec_bld - interface mld_mlprec_aply subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ @@ -95,20 +94,6 @@ module mld_d_inner_mod end subroutine mld_dmlprec_aply_vect end interface mld_mlprec_aply - - interface mld_coarse_bld - subroutine mld_dcoarse_bld(a,desc_a,p,info) - use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ - use mld_d_prec_type, only : mld_d_onelev_type - implicit none - type(psb_dspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - type(mld_d_onelev_type), intent(inout), target :: p - integer(psb_ipk_), intent(out) :: info - end subroutine mld_dcoarse_bld - end interface mld_coarse_bld - - interface mld_bld_mlhier_aggsize subroutine mld_d_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type,psb_dpk_ diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index 6e8de542..885a11e2 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -120,8 +120,8 @@ module mld_d_prec_mod end subroutine mld_d_extprol_bld end interface mld_extprol_bld - interface mld_ml_prec_bld - subroutine mld_d_ml_prec_bld(a,desc_a,prec,info,amold,vmold,imold) + interface mld_smoothers_bld + subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & psb_d_base_sparse_mat, psb_d_base_vect_type, & & psb_i_base_vect_type, mld_dprec_type, psb_ipk_ @@ -134,8 +134,8 @@ module mld_d_prec_mod class(psb_d_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd - end subroutine mld_d_ml_prec_bld - end interface mld_ml_prec_bld + end subroutine mld_d_smoothers_bld + end interface mld_smoothers_bld contains diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index 279e45df..ae4398ed 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -64,7 +64,6 @@ module mld_s_inner_mod end subroutine mld_smlprec_bld end interface mld_mlprec_bld - interface mld_mlprec_aply subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_ @@ -95,20 +94,6 @@ module mld_s_inner_mod end subroutine mld_smlprec_aply_vect end interface mld_mlprec_aply - - interface mld_coarse_bld - subroutine mld_scoarse_bld(a,desc_a,p,info) - use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_ - use mld_s_prec_type, only : mld_s_onelev_type - implicit none - type(psb_sspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - type(mld_s_onelev_type), intent(inout), target :: p - integer(psb_ipk_), intent(out) :: info - end subroutine mld_scoarse_bld - end interface mld_coarse_bld - - interface mld_bld_mlhier_aggsize subroutine mld_s_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type,psb_spk_ diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index b7b4ddc9..6fe68623 100644 --- a/mlprec/mld_s_prec_mod.f90 +++ b/mlprec/mld_s_prec_mod.f90 @@ -120,8 +120,8 @@ module mld_s_prec_mod end subroutine mld_s_extprol_bld end interface mld_extprol_bld - interface mld_ml_prec_bld - subroutine mld_s_ml_prec_bld(a,desc_a,prec,info,amold,vmold,imold) + interface mld_smoothers_bld + subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & psb_s_base_sparse_mat, psb_s_base_vect_type, & & psb_i_base_vect_type, mld_sprec_type, psb_ipk_ @@ -134,8 +134,8 @@ module mld_s_prec_mod class(psb_s_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd - end subroutine mld_s_ml_prec_bld - end interface mld_ml_prec_bld + end subroutine mld_s_smoothers_bld + end interface mld_smoothers_bld contains diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index 72e64ac6..d9b1c549 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -64,7 +64,6 @@ module mld_z_inner_mod end subroutine mld_zmlprec_bld end interface mld_mlprec_bld - interface mld_mlprec_aply subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ @@ -95,20 +94,6 @@ module mld_z_inner_mod end subroutine mld_zmlprec_aply_vect end interface mld_mlprec_aply - - interface mld_coarse_bld - subroutine mld_zcoarse_bld(a,desc_a,p,info) - use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ - use mld_z_prec_type, only : mld_z_onelev_type - implicit none - type(psb_zspmat_type), intent(in), target :: a - type(psb_desc_type), intent(in), target :: desc_a - type(mld_z_onelev_type), intent(inout), target :: p - integer(psb_ipk_), intent(out) :: info - end subroutine mld_zcoarse_bld - end interface mld_coarse_bld - - interface mld_bld_mlhier_aggsize subroutine mld_z_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type,psb_dpk_ diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index 1d2f203f..d301b49b 100644 --- a/mlprec/mld_z_prec_mod.f90 +++ b/mlprec/mld_z_prec_mod.f90 @@ -120,8 +120,8 @@ module mld_z_prec_mod end subroutine mld_z_extprol_bld end interface mld_extprol_bld - interface mld_ml_prec_bld - subroutine mld_z_ml_prec_bld(a,desc_a,prec,info,amold,vmold,imold) + interface mld_smoothers_bld + subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & psb_z_base_sparse_mat, psb_z_base_vect_type, & & psb_i_base_vect_type, mld_zprec_type, psb_ipk_ @@ -134,8 +134,8 @@ module mld_z_prec_mod class(psb_z_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd - end subroutine mld_z_ml_prec_bld - end interface mld_ml_prec_bld + end subroutine mld_z_smoothers_bld + end interface mld_smoothers_bld contains