diff --git a/Changelog b/Changelog index ade0be90..b58366ec 100644 --- a/Changelog +++ b/Changelog @@ -1,5 +1,9 @@ Changelog. A lot less detailed than usual, at least for past history. +2016/10/03: Merged changes to hierearchy building. +2016/08/20: Reimplemented decoupled aggregation +2016/07/20: Refactored application of multilevel. Defined V,W and + K-cycles. 2016/05/18: Reworked internals of PRECSET. Defined Forward-Backward Gauss-Seidel solver. Now available separate PRE and POST smoother objects. diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index c9c0e713..9d4070ee 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -22,29 +22,29 @@ 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 \ - mld_d_ml_prec_bld.o mld_d_hierarchy_bld.o \ +DINNEROBJS= mld_dmlprec_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 + $(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 \ +SINNEROBJS= mld_smlprec_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 + $(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 \ +ZINNEROBJS= mld_zmlprec_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 + $(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 \ +CINNEROBJS= mld_cmlprec_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 + $(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_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_dec_map_bld.f90 b/mlprec/impl/mld_c_dec_map_bld.f90 index fdc05234..0084692d 100644 --- a/mlprec/impl/mld_c_dec_map_bld.f90 +++ b/mlprec/impl/mld_c_dec_map_bld.f90 @@ -59,7 +59,7 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) 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, 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 @@ -138,16 +138,14 @@ 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 ! ! If the whole strongly coupled neighborhood of I is - ! as yet unconnected, turn it into the next aggregate + ! 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)) + disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) if (disjoint) then icnt = icnt + 1 naggr = naggr + 1 @@ -207,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) < 0) 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_ @@ -218,7 +216,7 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! 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..836a6905 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,16 +76,17 @@ 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 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, 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 + type(mld_c_onelev_type), allocatable :: tprecv(:) integer(psb_ipk_) :: int_err(5) character :: upd_ integer(psb_ipk_) :: debug_level, debug_unit @@ -191,10 +181,22 @@ 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 falls below the min_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 +206,194 @@ 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 + + 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) + ! 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 + ! 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 + 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) - 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 = i-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) 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 + + 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 +401,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' @@ -232,4 +413,58 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) 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_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_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_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..ba0bda60 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,11 @@ 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_c_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + 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 @@ -133,26 +133,26 @@ subroutine mld_caggrmat_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_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_ @@ -165,116 +165,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..d1ce58f9 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),& @@ -197,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 7ebcb689..58e45cd6 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) @@ -316,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 @@ -454,7 +426,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..ed72e9ee 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),& @@ -212,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_ccprecset.F90 b/mlprec/impl/mld_ccprecset.F90 index 4551fd1e..8c39848f 100644 --- a/mlprec/impl/mld_ccprecset.F90 +++ b/mlprec/impl/mld_ccprecset.F90 @@ -519,7 +519,6 @@ 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) diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index d9e4b826..ba53ea68 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_ @@ -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_cprecinit.F90 b/mlprec/impl/mld_cprecinit.F90 index c6e3330f..7435f11f 100644 --- a/mlprec/impl/mld_cprecinit.F90 +++ b/mlprec/impl/mld_cprecinit.F90 @@ -207,7 +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_no_filter_mat_,info) + call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info) end do case default 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_dec_map_bld.f90 b/mlprec/impl/mld_d_dec_map_bld.f90 index 40d874a7..ecbf5a8b 100644 --- a/mlprec/impl/mld_d_dec_map_bld.f90 +++ b/mlprec/impl/mld_d_dec_map_bld.f90 @@ -59,7 +59,7 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) 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 @@ -138,16 +138,14 @@ 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 ! ! If the whole strongly coupled neighborhood of I is - ! as yet unconnected, turn it into the next aggregate + ! 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)) + disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) if (disjoint) then icnt = icnt + 1 naggr = naggr + 1 @@ -207,7 +205,7 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) step3: do ii=1,nr i = idxs(ii) - if (ilaggr(i) < 0) 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_ diff --git a/mlprec/impl/mld_d_hierarchy_bld.f90 b/mlprec/impl/mld_d_hierarchy_bld.f90 index c43238dd..c6061345 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,16 +76,17 @@ 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 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, 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 + type(mld_d_onelev_type), allocatable :: tprecv(:) integer(psb_ipk_) :: int_err(5) character :: upd_ integer(psb_ipk_) :: debug_level, debug_unit @@ -191,10 +181,22 @@ 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 falls below the min_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 +206,194 @@ 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 + 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 + + 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) + ! 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 + ! 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 + 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) - 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 = i-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) 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 + + 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 +401,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' @@ -232,4 +413,58 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) 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_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_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_daggrmap_bld.f90 b/mlprec/impl/mld_daggrmap_bld.f90 index c652983a..f8e6d7cc 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 @@ -93,13 +93,14 @@ subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) 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 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,28 @@ 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 82613c50..5ee9b0e4 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,11 @@ 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(psb_dspmat_type), intent(inout) :: ac, op_prol,op_restr integer(psb_ipk_), intent(out) :: info ! 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 +133,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_ @@ -165,116 +165,6 @@ subroutine mld_daggrmat_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_daggrmat_biz_asb.f90 b/mlprec/impl/mld_daggrmat_biz_asb.f90 index 90f95927..f65f16eb 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),& @@ -197,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 09e7bad6..f54912d3 100644 --- a/mlprec/impl/mld_daggrmat_minnrg_asb.f90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 @@ -108,8 +108,9 @@ 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(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr + 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 ! 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 @@ -276,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) @@ -316,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 @@ -454,7 +426,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_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..390f5b71 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,14 +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_) - 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),& @@ -212,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_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 6d624a63..005ecbba 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -529,7 +529,6 @@ 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) diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index ac2f3923..9fbe1c70 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_ @@ -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_dprecinit.F90 b/mlprec/impl/mld_dprecinit.F90 index b4ab1d50..cdb3f7b2 100644 --- a/mlprec/impl/mld_dprecinit.F90 +++ b/mlprec/impl/mld_dprecinit.F90 @@ -212,7 +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_no_filter_mat_,info) + call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info) end do case default 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_dec_map_bld.f90 b/mlprec/impl/mld_s_dec_map_bld.f90 index b4749ab2..afd107fa 100644 --- a/mlprec/impl/mld_s_dec_map_bld.f90 +++ b/mlprec/impl/mld_s_dec_map_bld.f90 @@ -59,7 +59,7 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) 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, 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 @@ -138,16 +138,14 @@ 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 ! ! If the whole strongly coupled neighborhood of I is - ! as yet unconnected, turn it into the next aggregate + ! 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)) + disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) if (disjoint) then icnt = icnt + 1 naggr = naggr + 1 @@ -207,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) < 0) 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_ @@ -218,7 +216,7 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) ! 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..b6c1f269 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,16 +76,17 @@ 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 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, 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 + type(mld_s_onelev_type), allocatable :: tprecv(:) integer(psb_ipk_) :: int_err(5) character :: upd_ integer(psb_ipk_) :: debug_level, debug_unit @@ -191,10 +181,22 @@ 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 falls below the min_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 +206,194 @@ 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 + + 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) + ! 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 + ! 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 + 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) - 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 = i-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) 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 + + 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 +401,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' @@ -232,4 +413,58 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) 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_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_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_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..e540c117 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,11 @@ 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_s_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + 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 @@ -133,26 +133,26 @@ subroutine mld_saggrmat_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_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_ @@ -165,116 +165,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..946bb3eb 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),& @@ -197,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 e9e15e4a..defca9c0 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) @@ -316,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 @@ -454,7 +426,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..4fc52ab2 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),& @@ -212,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_scprecset.F90 b/mlprec/impl/mld_scprecset.F90 index 40c74d8a..ae70a83b 100644 --- a/mlprec/impl/mld_scprecset.F90 +++ b/mlprec/impl/mld_scprecset.F90 @@ -519,7 +519,6 @@ 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) diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index 8f9d4502..761df534 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_ @@ -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_sprecinit.F90 b/mlprec/impl/mld_sprecinit.F90 index f3fba2fc..692b55ca 100644 --- a/mlprec/impl/mld_sprecinit.F90 +++ b/mlprec/impl/mld_sprecinit.F90 @@ -207,7 +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_no_filter_mat_,info) + call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info) end do case default 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_dec_map_bld.f90 b/mlprec/impl/mld_z_dec_map_bld.f90 index 26552856..dffb3402 100644 --- a/mlprec/impl/mld_z_dec_map_bld.f90 +++ b/mlprec/impl/mld_z_dec_map_bld.f90 @@ -59,7 +59,7 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info) 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, 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 @@ -138,16 +138,14 @@ 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 ! ! If the whole strongly coupled neighborhood of I is - ! as yet unconnected, turn it into the next aggregate + ! 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)) + disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) if (disjoint) then icnt = icnt + 1 naggr = naggr + 1 @@ -207,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) < 0) 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_ diff --git a/mlprec/impl/mld_z_hierarchy_bld.f90 b/mlprec/impl/mld_z_hierarchy_bld.f90 index ab14a40a..6b6a306e 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,16 +76,17 @@ 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 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, 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 + type(mld_z_onelev_type), allocatable :: tprecv(:) integer(psb_ipk_) :: int_err(5) character :: upd_ integer(psb_ipk_) :: debug_level, debug_unit @@ -191,10 +181,22 @@ 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 falls below the min_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 +206,194 @@ 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 + + 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) + ! 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 + ! 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 + 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) - 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 = i-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) 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 + + 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 +401,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' @@ -232,4 +413,58 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) 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_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_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_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..1cd620a5 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,11 @@ 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_z_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + 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 @@ -133,26 +133,26 @@ subroutine mld_zaggrmat_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_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_ @@ -165,116 +165,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..a79f7c70 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),& @@ -197,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 ba0238e0..1e52efd5 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) @@ -316,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 @@ -454,7 +426,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..0f632736 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),& @@ -212,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 diff --git a/mlprec/impl/mld_zcprecset.F90 b/mlprec/impl/mld_zcprecset.F90 index 9ecc4a92..abdd925b 100644 --- a/mlprec/impl/mld_zcprecset.F90 +++ b/mlprec/impl/mld_zcprecset.F90 @@ -529,7 +529,6 @@ 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) diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index b1532029..50253ac9 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_ @@ -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/impl/mld_zprecinit.F90 b/mlprec/impl/mld_zprecinit.F90 index 1dac23a8..f6f9a4b7 100644 --- a/mlprec/impl/mld_zprecinit.F90 +++ b/mlprec/impl/mld_zprecinit.F90 @@ -212,7 +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_no_filter_mat_,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 8d2675ed..1389568b 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 @@ -258,10 +258,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_ @@ -338,8 +339,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. '/) @@ -453,6 +454,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') diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 9da1ce64..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_ @@ -124,11 +109,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) - use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type + 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, psb_spk_ 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,7 +123,18 @@ module mld_c_inner_mod end interface mld_bld_mlhier_array interface mld_aggrmap_bld - subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) + 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,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 @@ -146,6 +143,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 @@ -165,15 +163,30 @@ module mld_c_inner_mod end interface mld_dec_map_bld - interface mld_aggrmat_asb - subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + 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,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_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_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index 5d0fea10..7a0e06cb 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 @@ -124,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_ @@ -138,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 bf891db2..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_ @@ -124,11 +109,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 +123,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_), 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 +143,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,15 +163,30 @@ 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) + 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 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_lev_mat_asb + + interface mld_aggrmat_asb + 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_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_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index 25a6ba3c..885a11e2 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 @@ -124,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_ @@ -138,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 ed6dfa77..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_ @@ -124,11 +109,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) - use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type + 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, psb_spk_ 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,7 +123,18 @@ module mld_s_inner_mod end interface mld_bld_mlhier_array interface mld_aggrmap_bld - subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) + 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,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 @@ -146,6 +143,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 @@ -165,15 +163,30 @@ module mld_s_inner_mod end interface mld_dec_map_bld - interface mld_aggrmat_asb - subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + 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,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_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_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index da3d546d..6fe68623 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 @@ -124,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_ @@ -138,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 2af263d8..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_ @@ -124,11 +109,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) - use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type + 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, psb_dpk_ 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,7 +123,18 @@ module mld_z_inner_mod end interface mld_bld_mlhier_array interface mld_aggrmap_bld - subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info) + 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,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 @@ -146,6 +143,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 @@ -165,15 +163,30 @@ module mld_z_inner_mod end interface mld_dec_map_bld - interface mld_aggrmat_asb - subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + 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,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_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 diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index cd1aa321..d301b49b 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 @@ -124,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_ @@ -138,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 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 07020a0c..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,6 +187,8 @@ program mld_d_pde3d 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 @@ -214,7 +217,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 @@ -258,6 +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', prectype%aggr_filter, info) call psb_barrier(ictxt) t1 = psb_wtime() @@ -380,6 +385,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 +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_dpk_) :: 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/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 66d7129d..2feabc54 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,35 +1,38 @@ 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 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 +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) -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 +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 -ILU ! Coarse level: subsolver DSCALE GS BWGS ILU 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) 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