From 32e344aea4647260a7efd312133764a58b8d9bc8 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 11 Jul 2016 08:42:51 +0000 Subject: [PATCH] mld2p4-2: mlprec/impl/Makefile mlprec/impl/mld_d_extprol_bld.f90 mlprec/mld_base_prec_type.F90 mlprec/mld_d_prec_mod.f90 Define an externally-specified aggregation, --- mlprec/impl/Makefile | 2 +- mlprec/impl/mld_d_extprol_bld.f90 | 519 ++++++++++++++++++++++++++++++ mlprec/mld_base_prec_type.F90 | 50 +-- mlprec/mld_d_prec_mod.f90 | 37 ++- 4 files changed, 576 insertions(+), 32 deletions(-) create mode 100644 mlprec/impl/mld_d_extprol_bld.f90 diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index 9123bd18..37258583 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) + $(DMPFOBJS) mld_d_extprol_bld.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_extprol_bld.f90 b/mlprec/impl/mld_d_extprol_bld.f90 new file mode 100644 index 00000000..27188e12 --- /dev/null +++ b/mlprec/impl/mld_d_extprol_bld.f90 @@ -0,0 +1,519 @@ +!!$ +!!$ +!!$ 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_d_hierarchy_bld.f90 +! +! Subroutine: mld_d_hierarchy_bld +! Version: real +! +! This routine builds the preconditioner according to the requirements made by +! the user trough the subroutines mld_precinit and mld_precset. +! +! A multilevel preconditioner is regarded as an array of 'one-level' data structures, +! each containing the part of the preconditioner associated to a certain level, +! (for more details see the description of mld_Tonelev_type in mld_prec_type.f90). +! The levels are numbered in increasing order starting from the finest one, i.e. +! level 1 is the finest level. No transfer operators are associated to level 1. +! +! +! Arguments: +! a - type(psb_dspmat_type). +! The sparse matrix structure containing the local part of the +! matrix to be preconditioned. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of a. +! p - type(mld_dprec_type), input/output. +! The preconditioner data structure containing the local part +! 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_extprol_bld(a,desc_a,p,prolv,restrv,info,amold,vmold,imold) + + use psb_base_mod + use mld_d_inner_mod + use mld_d_prec_mod, mld_protect_name => mld_d_extprol_bld + + Implicit None + + ! Arguments + type(psb_dspmat_type),intent(in), target :: a + type(psb_dspmat_type),intent(in), target :: prolv(:) + type(psb_dspmat_type),intent(in), target :: restrv(:) + 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 + integer(psb_ipk_) :: ictxt, me,np + integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs + integer(psb_ipk_) :: nprolv, nrestrv + real(psb_dpk_) :: mnaggratio + 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) + character :: upd_ + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name, ch_err + + 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() + + name = 'mld_d_extprol_bld' + info = psb_success_ + int_err(1) = 0 + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + p%ictxt = ictxt + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Entering ' + ! + ! For the time being we are commenting out the UPDATE argument + ! we plan to resurrect it later. + ! !$ if (present(upd)) then + ! !$ if (debug_level >= psb_debug_outer_) & + ! !$ & write(debug_unit,*) me,' ',trim(name),'UPD ', upd + ! !$ + ! !$ if ((psb_toupper(upd).eq.'F').or.(psb_toupper(upd).eq.'T')) then + ! !$ upd_=psb_toupper(upd) + ! !$ else + ! !$ upd_='F' + ! !$ endif + ! !$ else + ! !$ upd_='F' + ! !$ endif + upd_ = 'F' + + if (.not.allocated(p%precv)) then + !! Error: should have called mld_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + ! + ! Check to ensure all procs have the same + ! + newsz = -1 + casize = p%coarse_aggr_size + nplevs = p%n_prec_levs + mxplevs = p%max_prec_levs + mnaggratio = p%min_aggr_ratio + casize = p%coarse_aggr_size + iszv = size(p%precv) + nprolv = size(prolv) + nrestrv = size(restrv) + call psb_bcast(ictxt,iszv) + call psb_bcast(ictxt,casize) + call psb_bcast(ictxt,nplevs) + call psb_bcast(ictxt,mxplevs) + call psb_bcast(ictxt,mnaggratio) + call psb_bcast(ictxt,nprolv) + call psb_bcast(ictxt,nrestrv) + if (casize /= p%coarse_aggr_size) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size') + goto 9999 + end if + if (nplevs /= p%n_prec_levs) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent n_prec_levs') + goto 9999 + end if + if (mxplevs /= p%max_prec_levs) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent max_prec_levs') + goto 9999 + end if + if (mnaggratio /= p%min_aggr_ratio) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent min_aggr_ratio') + goto 9999 + end if + if (iszv /= size(p%precv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of precv') + goto 9999 + end if + if (nprolv /= size(prolv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of prolv') + goto 9999 + end if + if (nrestrv /= size(restrv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of restrv') + goto 9999 + end if + if (nrestrv /= nprolv) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size prolv vs restrv') + goto 9999 + end if + + if (iszv <= 1) then + ! We should only ever get here for multilevel. + info=psb_err_from_subroutine_ + ch_err='size bpv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if (nrestrv < 1) then + ! We should only ever get here for multilevel. + info=psb_err_from_subroutine_ + ch_err='size restrv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + ! + nplevs = nrestrv + 1 + p%n_prec_levs = nplevs + + ! + ! Fixed number of levels. + ! + 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 + + 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 + + ! + ! Sanity checks on the parameters + ! + if (i2) then + if (all(p%precv(i)%map%naggr == p%precv(i-1)%map%naggr)) then + newsz=i-1 + end if + call psb_bcast(ictxt,newsz) + if (newsz > 0) exit array_build_loop + end if + end do array_build_loop + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Internal hierarchy build' ) + goto 9999 + endif + + iszv = size(p%precv) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Exiting with',iszv,' levels' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine mld_d_extaggr_bld(a,desc_a,p,op_restr,op_prol,info) + use psb_base_mod + use mld_d_inner_mod + + implicit none + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + type(psb_dspmat_type), intent(inout) :: op_restr,op_prol + type(psb_desc_type), intent(in), target :: desc_a + type(mld_d_onelev_type), intent(inout),target :: p + integer(psb_ipk_), intent(out) :: info + + ! Local variables + character(len=20) :: name + integer(psb_mpik_) :: ictxt, np, me, ncol + integer(psb_ipk_) :: err_act,ntaggr,nzl + integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:) + type(psb_dspmat_type) :: ac, am3, am4 + type(psb_d_coo_sparse_mat) :: acoo, bcoo + type(psb_d_csr_sparse_mat) :: acsr1 + + + name='mld_d_extaggr_bld' + if (psb_get_errstatus().ne.0) return + call psb_erractionsave(err_act) + info = psb_success_ + ictxt = desc_a%get_context() + call psb_info(ictxt,me,np) + allocate(nlaggr(np),ilaggr(1)) + nlaggr = 0 + ilaggr = 0 + p%parms%aggr_alg = mld_ext_aggr_ + call mld_check_def(p%parms%ml_type,'Multilevel type',& + & mld_mult_ml_,is_legal_ml_type) + call mld_check_def(p%parms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_legal_ml_coarse_mat) + + nlaggr(me+1) = op_restr%get_nrows() + if (op_restr%get_nrows() /= op_prol%get_ncols()) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent restr/prol sizes') + goto 9999 + end if + call psb_sum(ictxt,nlaggr) + ntaggr = sum(nlaggr) + ncol = desc_a%get_local_cols() + ! + ! Compute local part of AC + ! + call psb_spspmm(a,op_prol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 2') + goto 9999 + end if + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) + if (info == psb_success_) call am4%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') + goto 9999 + end if + call psb_spspmm(op_restr,am3,ac,info) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3') + goto 9999 + end if + + 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 + call op_restr%set_nrows(p%desc_ac%get_local_cols()) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if ((info == psb_success_).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_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end subroutine mld_d_extaggr_bld + +end subroutine mld_d_extprol_bld diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 59a74318..48cbe000 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -256,10 +256,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_glb_aggr_ = 2 - integer(psb_ipk_), parameter :: mld_new_dec_aggr_ = 3 - integer(psb_ipk_), parameter :: mld_new_glb_aggr_ = 4 - integer(psb_ipk_), parameter :: mld_max_aggr_alg_ = mld_sym_dec_aggr_ + 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_max_aggr_alg_ = mld_ext_aggr_ ! ! Legal values for entry: mld_aggr_ord_ ! @@ -333,17 +334,20 @@ module mld_base_prec_type character(len=15), parameter, private :: & & matrix_names(0:1)=(/'distributed ','replicated '/) character(len=18), parameter, private :: & - & aggr_names(0:4)=(/'local aggregation ','sym. local aggr. ',& - & 'global aggregation', 'new local aggr. ','new global aggr. '/) + & aggr_names(0:5)=(/'local aggregation ','sym. local 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. '/) character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) character(len=12), parameter, private :: & - & prolong_names(0:3)=(/'none ','sum ','average ','square root'/) + & prolong_names(0:3)=(/'none ','sum ', & + & 'average ','square root'/) character(len=15), parameter, private :: & - & ml_names(0:7)=(/'none ','additive ','multiplicative',& - & 'VCycle ','WCycle ','KCycle ','KCycleSym ','new ML '/) + & ml_names(0:7)=(/'none ','additive ',& + & 'multiplicative', 'VCycle ','WCycle ',& + & 'KCycle ','KCycleSym ','new ML '/) character(len=15), parameter :: & & mld_fact_names(0:mld_max_sub_solve_)=(/& & 'none ','none ',& @@ -578,19 +582,21 @@ contains write(iout,*) ' Aggregation: ', & & aggr_names(pm%aggr_alg) - write(iout,*) ' with initial ordering: ',& - & ord_names(pm%aggr_ord) - write(iout,*) ' Aggregation type: ', & - & aggr_kinds(pm%aggr_kind) - if (pm%aggr_kind /= mld_no_smooth_) then - if (pm%aggr_omega_alg == mld_eig_est_) then - write(iout,*) ' Damping omega computation: spectral radius estimate' - write(iout,*) ' Spectral radius estimate: ', & - & eigen_estimates(pm%aggr_eig) - else if (pm%aggr_omega_alg == mld_user_choice_) then - write(iout,*) ' Damping omega computation: user defined value.' - else - write(iout,*) ' Damping omega computation: unknown value in iprcparm!!' + if (pm%aggr_alg /= mld_ext_aggr_) then + write(iout,*) ' with initial ordering: ',& + & ord_names(pm%aggr_ord) + write(iout,*) ' Aggregation type: ', & + & aggr_kinds(pm%aggr_kind) + if (pm%aggr_kind /= mld_no_smooth_) then + if (pm%aggr_omega_alg == mld_eig_est_) then + write(iout,*) ' Damping omega computation: spectral radius estimate' + write(iout,*) ' Spectral radius estimate: ', & + & eigen_estimates(pm%aggr_eig) + else if (pm%aggr_omega_alg == mld_user_choice_) then + write(iout,*) ' Damping omega computation: user defined value.' + else + write(iout,*) ' Damping omega computation: unknown value in iprcparm!!' + end if end if end if else diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index b97a9934..f90e974b 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -52,7 +52,7 @@ module mld_d_prec_mod use mld_d_diag_solver use mld_d_ilu_solver use mld_d_gs_solver - + interface mld_precinit subroutine mld_dprecinit(p,ptype,info,nlev) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & @@ -62,13 +62,13 @@ module mld_d_prec_mod integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: nlev end subroutine mld_dprecinit - end interface + end interface mld_precinit interface mld_precset module procedure mld_d_iprecsetsm, mld_d_iprecsetsv, & & mld_d_iprecseti, mld_d_iprecsetc, mld_d_iprecsetr, & & mld_d_cprecseti, mld_d_cprecsetc, mld_d_cprecsetr - end interface + end interface mld_precset interface mld_precbld subroutine mld_dprecbld(a,desc_a,prec,info,amold,vmold,imold) @@ -83,9 +83,9 @@ module mld_d_prec_mod 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 + ! character, intent(in),optional :: upd end subroutine mld_dprecbld - end interface + end interface mld_precbld interface mld_hierarchy_bld subroutine mld_d_hierarchy_bld(a,desc_a,prec,info,amold,vmold,imold) @@ -100,9 +100,28 @@ module mld_d_prec_mod 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 + ! character, intent(in),optional :: upd end subroutine mld_d_hierarchy_bld - end interface + end interface mld_hierarchy_bld + + interface mld_extprol_bld + subroutine mld_d_extprol_bld(a,desc_a,p,prolv,restrv,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_ + implicit none + ! Arguments + type(psb_dspmat_type),intent(in), target :: a + type(psb_dspmat_type),intent(in), target :: prolv(:) + type(psb_dspmat_type),intent(in), target :: restrv(:) + 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 + 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) @@ -117,9 +136,9 @@ module mld_d_prec_mod 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 + ! character, intent(in),optional :: upd end subroutine mld_d_ml_prec_bld - end interface + end interface mld_ml_prec_bld contains