From 0d36e968c3e73f40c956006efcbf4383eb5ee3a3 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 1 Oct 2016 19:01:35 +0000 Subject: [PATCH] mld2p4-extaggr: mlprec/impl/Makefile mlprec/impl/mld_c_bld_mlhier_aggsize.f90 mlprec/impl/mld_c_bld_mlhier_array.f90 mlprec/impl/mld_c_hierarchy_bld.f90 mlprec/impl/mld_cmlprec_bld.f90 mlprec/impl/mld_d_bld_mlhier_aggsize.f90 mlprec/impl/mld_d_bld_mlhier_array.f90 mlprec/impl/mld_d_hierarchy_bld.f90 mlprec/impl/mld_dmlprec_bld.f90 mlprec/impl/mld_s_bld_mlhier_aggsize.f90 mlprec/impl/mld_s_bld_mlhier_array.f90 mlprec/impl/mld_s_hierarchy_bld.f90 mlprec/impl/mld_smlprec_bld.f90 mlprec/impl/mld_z_bld_mlhier_aggsize.f90 mlprec/impl/mld_z_bld_mlhier_array.f90 mlprec/impl/mld_z_hierarchy_bld.f90 mlprec/impl/mld_zmlprec_bld.f90 mlprec/mld_c_prec_mod.f90 mlprec/mld_d_prec_mod.f90 mlprec/mld_s_prec_mod.f90 mlprec/mld_z_prec_mod.f90 Taken out mold from hierarchy_bld. bld_mlhier_aggsize and bld_mlhier_array are now superseded. --- mlprec/impl/Makefile | 8 +- mlprec/impl/mld_c_bld_mlhier_aggsize.f90 | 268 ----------------------- mlprec/impl/mld_c_bld_mlhier_array.f90 | 246 --------------------- mlprec/impl/mld_c_hierarchy_bld.f90 | 19 +- mlprec/impl/mld_cmlprec_bld.f90 | 2 +- mlprec/impl/mld_d_bld_mlhier_aggsize.f90 | 268 ----------------------- mlprec/impl/mld_d_bld_mlhier_array.f90 | 246 --------------------- mlprec/impl/mld_d_hierarchy_bld.f90 | 19 +- mlprec/impl/mld_dmlprec_bld.f90 | 2 +- mlprec/impl/mld_s_bld_mlhier_aggsize.f90 | 268 ----------------------- mlprec/impl/mld_s_bld_mlhier_array.f90 | 246 --------------------- mlprec/impl/mld_s_hierarchy_bld.f90 | 19 +- mlprec/impl/mld_smlprec_bld.f90 | 2 +- mlprec/impl/mld_z_bld_mlhier_aggsize.f90 | 268 ----------------------- mlprec/impl/mld_z_bld_mlhier_array.f90 | 246 --------------------- mlprec/impl/mld_z_hierarchy_bld.f90 | 19 +- mlprec/impl/mld_zmlprec_bld.f90 | 2 +- mlprec/mld_c_prec_mod.f90 | 8 +- mlprec/mld_d_prec_mod.f90 | 8 +- mlprec/mld_s_prec_mod.f90 | 8 +- mlprec/mld_z_prec_mod.f90 | 8 +- 21 files changed, 24 insertions(+), 2156 deletions(-) delete mode 100644 mlprec/impl/mld_c_bld_mlhier_aggsize.f90 delete mode 100644 mlprec/impl/mld_c_bld_mlhier_array.f90 delete mode 100644 mlprec/impl/mld_d_bld_mlhier_aggsize.f90 delete mode 100644 mlprec/impl/mld_d_bld_mlhier_array.f90 delete mode 100644 mlprec/impl/mld_s_bld_mlhier_aggsize.f90 delete mode 100644 mlprec/impl/mld_s_bld_mlhier_array.f90 delete mode 100644 mlprec/impl/mld_z_bld_mlhier_aggsize.f90 delete mode 100644 mlprec/impl/mld_z_bld_mlhier_array.f90 diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index 84b4bfd1..e03c55fc 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -22,25 +22,25 @@ MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS) MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o -DINNEROBJS= mld_dmlprec_bld.o mld_d_bld_mlhier_aggsize.o mld_d_bld_mlhier_array.o \ +DINNEROBJS= mld_dmlprec_bld.o \ mld_d_ml_prec_bld.o mld_d_hierarchy_bld.o \ mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \ mld_d_dec_map_bld.o mld_dmlprec_aply.o mld_daggrmat_asb.o \ $(DMPFOBJS) mld_d_extprol_bld.o mld_d_lev_aggrmap_bld.o mld_d_lev_aggrmat_asb.o -SINNEROBJS= mld_smlprec_bld.o mld_s_bld_mlhier_aggsize.o mld_s_bld_mlhier_array.o \ +SINNEROBJS= mld_smlprec_bld.o \ mld_s_ml_prec_bld.o mld_s_hierarchy_bld.o \ mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o mld_saggrmap_bld.o \ mld_s_dec_map_bld.o mld_smlprec_aply.o mld_saggrmat_asb.o \ $(SMPFOBJS) mld_s_extprol_bld.o mld_s_lev_aggrmap_bld.o mld_s_lev_aggrmat_asb.o -ZINNEROBJS= mld_zmlprec_bld.o mld_z_bld_mlhier_aggsize.o mld_z_bld_mlhier_array.o \ +ZINNEROBJS= mld_zmlprec_bld.o \ mld_z_ml_prec_bld.o mld_z_hierarchy_bld.o \ mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \ mld_z_dec_map_bld.o mld_zmlprec_aply.o mld_zaggrmat_asb.o \ $(ZMPFOBJS) mld_z_extprol_bld.o mld_z_lev_aggrmap_bld.o mld_z_lev_aggrmat_asb.o -CINNEROBJS= mld_cmlprec_bld.o mld_c_bld_mlhier_aggsize.o mld_c_bld_mlhier_array.o \ +CINNEROBJS= mld_cmlprec_bld.o \ mld_c_ml_prec_bld.o mld_c_hierarchy_bld.o \ mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \ mld_c_dec_map_bld.o mld_cmlprec_aply.o mld_caggrmat_asb.o \ diff --git a/mlprec/impl/mld_c_bld_mlhier_aggsize.f90 b/mlprec/impl/mld_c_bld_mlhier_aggsize.f90 deleted file mode 100644 index cf3ec60e..00000000 --- a/mlprec/impl/mld_c_bld_mlhier_aggsize.f90 +++ /dev/null @@ -1,268 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Build an aggregation hierarchy with a target aggregation size -! -! -subroutine mld_c_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) - use psb_base_mod - use mld_c_inner_mod, mld_protect_name => mld_c_bld_mlhier_aggsize - use mld_c_prec_mod - implicit none - integer(psb_ipk_), intent(in) :: casize,mxplevs - real(psb_spk_) :: mnaggratio - type(psb_cspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_c_onelev_type), allocatable, target, intent(inout) :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, iaggsize - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - integer(psb_ipk_) :: int_err(5) - character :: upd_ - class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2 - type(mld_sml_parms) :: baseparms, medparms, coarseparms - type(mld_c_onelev_node), pointer :: head, tail, newnode, current - real(psb_spk_) :: sizeratio - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_mlhier_aggsize' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - ! - ! New strategy to build according to coarse size. - ! - iszv = size(precv) - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if ((info == psb_success_).and.allocated(precv(1)%sm2a)) & - & allocate(base_sm2, source=precv(1)%sm2a,stat=info) - if ((info == psb_success_).and.allocated(precv(2)%sm2a)) & - & allocate(med_sm2, source=precv(2)%sm2a,stat=info) - if (info /= psb_success_) then - write(0,*) 'Error in saving smoothers',info - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - ! - ! Replicated matrix should only ever happen at coarse level. - ! - call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& - & mld_distr_mat_,is_distr_ml_coarse_mat) - ! - ! Now build a doubly linked list - ! - allocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='List start'); goto 9999 - end if - head => newnode - tail => newnode - newnode%item%base_a => a - newnode%item%base_desc => desc_a - newnode%item%parms = baseparms - newsz = 1 - current => head - list_build_loop: do - allocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='List start'); goto 9999 - end if - current%next => newnode - newnode%prev => current - newsz = newsz + 1 - newnode%item%parms = medparms - newnode%item%parms%aggr_thresh = & - & (current%item%parms%aggr_thresh)*(current%item%parms%aggr_scale) - call mld_coarse_bld(current%item%base_a, current%item%base_desc, & - & newnode%item,info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='build next level'); goto 9999 - end if - - current => current%next - tail => current - iaggsize = sum(current%item%map%naggr) - - if (iaggsize <= casize) then - ! - ! Target reached; but we may need to rebuild. - ! - exit list_build_loop - end if - if (newsz>2) then - sizeratio = iaggsize - sizeratio = sum(current%prev%item%map%naggr)/sizeratio - - if (sizeratio < mnaggratio) then - if (sizeratio > 1) exit list_build_loop - ! - ! We are not gaining - ! - newsz = newsz-1 - current => current%prev - current%next =>null() - call newnode%item%free(info) - if (info == psb_success_) deallocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 - end if - exit list_build_loop - end if - end if - - end do list_build_loop - ! - ! At this point, we are at the list tail. - ! If the top aggregation parameters were different, then we need to rebuild; - ! the threshold has to be fixed before rebuliding, and the parms must be - ! copied anyway since they'll be used later for the smoother build. - ! - coarseparms%aggr_thresh = current%item%parms%aggr_thresh - - if (.not.mld_equal_aggregation(current%item%parms, coarseparms)) then - ! Need to rebuild. - current%item%parms = coarseparms - call mld_coarse_bld(current%prev%item%base_a,& - & current%prev%item%base_desc, & - & current%item,info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='build next level'); goto 9999 - end if - else - ! Need only copy the parms. - current%item%parms = coarseparms - end if - ! - ! Ok, now allocate the output vector and fix items. - ! - do i=1,iszv - if (info == psb_success_) call precv(i)%free(info) - end do - if (info == psb_success_) deallocate(precv,stat=info) - if (info == psb_success_) allocate(precv(newsz),stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 - end if - newnode => head - do i=1, newsz - current => newnode - ! First do a move_alloc. - ! This handles the AC, DESC_AC and MAP fields - if (info == psb_success_) & - & call current%item%move_alloc(precv(i),info) - ! Now set the smoother/solver parts. - if (info == psb_success_) then - if (i ==1) then - allocate(precv(i)%sm,source=base_sm,stat=info) - if (allocated(base_sm2)) then - allocate(precv(i)%sm2a,source=base_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else if (i < newsz) then - allocate(precv(i)%sm,source=med_sm,stat=info) - if (allocated(med_sm2)) then - allocate(precv(i)%sm2a,source=med_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else - allocate(precv(i)%sm,source=coarse_sm,stat=info) - end if - end if - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='list cpy'); goto 9999 - end if - if (i == 1) then - precv(i)%base_a => a - precv(i)%base_desc => desc_a - else - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end if - - newnode => current%next - deallocate(current) - end do - call base_sm%free(info) - if (info == psb_success_) call med_sm%free(info) - if (info == psb_success_) call coarse_sm%free(info) - if ((info == psb_success_).and.(allocated(base_sm2))) call base_sm2%free(info) - if ((info == psb_success_).and.(allocated(med_sm2))) call med_sm2%free(info) - if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='final cleanup'); goto 9999 - end if - iszv = newsz - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_c_bld_mlhier_aggsize diff --git a/mlprec/impl/mld_c_bld_mlhier_array.f90 b/mlprec/impl/mld_c_bld_mlhier_array.f90 deleted file mode 100644 index da0d2279..00000000 --- a/mlprec/impl/mld_c_bld_mlhier_array.f90 +++ /dev/null @@ -1,246 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -subroutine mld_c_bld_mlhier_array(nplevs,a,desc_a,precv,info) - use psb_base_mod - use mld_c_inner_mod, mld_protect_name => mld_c_bld_mlhier_array - use mld_c_prec_mod - implicit none - integer(psb_ipk_), intent(inout) :: nplevs - type(psb_cspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_c_onelev_type),intent(inout), allocatable, target :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm - type(mld_sml_parms) :: baseparms, medparms, coarseparms - type(mld_c_onelev_type), allocatable :: tprecv(:) - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_array_hierarchy' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - iszv = size(precv) - - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if (info /= psb_success_) then - write(0,*) 'Error in saving smoothers',info - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - - ! - ! - ! Build the matrix and the transfer operators corresponding - ! to the remaining levels - ! - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,precv(1)%parms) - iszv = size(precv) - ! - ! First set desired number of levels - ! - if (iszv /= nplevs) then - allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - iszv = size(precv) - end if - - ! - ! Finest level first; remember to fix base_a and base_desc - ! - precv(1)%base_a => a - precv(1)%base_desc => desc_a - newsz = 0 - array_build_loop: do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,precv(i)%parms) - - ! - ! Sanity checks on the parameters - ! - if (i= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling mlprcbld at level ',i - ! - ! Build the mapping between levels i-1 and i and the matrix - ! at level i - ! - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, precv(i),info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Init upper level preconditioner') - goto 9999 - endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info - - if (i>2) then - if (all(precv(i)%map%naggr == precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop - end if - end do array_build_loop - - if (newsz > 0) then - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) - end if - allocate(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz-1 - call precv(i)%move_alloc(tprecv(i),info) - end do - call precv(iszv)%move_alloc(tprecv(newsz),info) - do i=newsz+1, iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - ! Ignore errors from transfer - info = psb_success_ - ! - ! Restart - iszv = newsz - ! Fix the pointers, but the level 1 should - ! be already OK - do i=2, iszv - 1 - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end do - - i = iszv - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, precv(i),info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') - goto 9999 - endif - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_c_bld_mlhier_array diff --git a/mlprec/impl/mld_c_hierarchy_bld.f90 b/mlprec/impl/mld_c_hierarchy_bld.f90 index 04d8548b..bad8ba82 100644 --- a/mlprec/impl/mld_c_hierarchy_bld.f90 +++ b/mlprec/impl/mld_c_hierarchy_bld.f90 @@ -62,19 +62,8 @@ ! of the preconditioner to be built. ! info - integer, output. ! Error code. -! -! amold - class(psb_c_base_sparse_mat), input, optional -! Mold for the inner format of matrices contained in the -! preconditioner -! -! -! vmold - class(psb_c_base_vect_type), input, optional -! Mold for the inner format of vectors contained in the -! preconditioner -! -! ! -subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_c_hierarchy_bld(a,desc_a,p,info) use psb_base_mod use mld_c_inner_mod @@ -87,9 +76,6 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) type(psb_desc_type), intent(inout), target :: desc_a type(mld_cprec_type),intent(inout),target :: p integer(psb_ipk_), intent(out) :: info - class(psb_c_base_sparse_mat), intent(in), optional :: amold - class(psb_c_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables @@ -206,11 +192,10 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! 4. If the size of the array is different from target number of levels, ! reallocate; ! 5. Build the matrix hierarchy, stopping early if either the target - ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! coarse size is hit, or the gain falls below the min_aggr_ratio ! threshold. ! - if (nplevs <= 0) then if (casize <=0) then ! diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index d9e4b826..d3ef5b41 100644 --- a/mlprec/impl/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -119,7 +119,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold) & write(debug_unit,*) me,' ',trim(name),& & 'Entering ' - call mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_c_hierarchy_bld(a,desc_a,p,info) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_d_bld_mlhier_aggsize.f90 b/mlprec/impl/mld_d_bld_mlhier_aggsize.f90 deleted file mode 100644 index 838ef25c..00000000 --- a/mlprec/impl/mld_d_bld_mlhier_aggsize.f90 +++ /dev/null @@ -1,268 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Build an aggregation hierarchy with a target aggregation size -! -! -subroutine mld_d_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) - use psb_base_mod - use mld_d_inner_mod, mld_protect_name => mld_d_bld_mlhier_aggsize - use mld_d_prec_mod - implicit none - integer(psb_ipk_), intent(in) :: casize,mxplevs - real(psb_dpk_) :: mnaggratio - type(psb_dspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_d_onelev_type), allocatable, target, intent(inout) :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, iaggsize - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - integer(psb_ipk_) :: int_err(5) - character :: upd_ - class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2 - type(mld_dml_parms) :: baseparms, medparms, coarseparms - type(mld_d_onelev_node), pointer :: head, tail, newnode, current - real(psb_dpk_) :: sizeratio - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_mlhier_aggsize' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - ! - ! New strategy to build according to coarse size. - ! - iszv = size(precv) - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if ((info == psb_success_).and.allocated(precv(1)%sm2a)) & - & allocate(base_sm2, source=precv(1)%sm2a,stat=info) - if ((info == psb_success_).and.allocated(precv(2)%sm2a)) & - & allocate(med_sm2, source=precv(2)%sm2a,stat=info) - if (info /= psb_success_) then - write(0,*) 'Error in saving smoothers',info - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - ! - ! Replicated matrix should only ever happen at coarse level. - ! - call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& - & mld_distr_mat_,is_distr_ml_coarse_mat) - ! - ! Now build a doubly linked list - ! - allocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='List start'); goto 9999 - end if - head => newnode - tail => newnode - newnode%item%base_a => a - newnode%item%base_desc => desc_a - newnode%item%parms = baseparms - newsz = 1 - current => head - list_build_loop: do - allocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='List start'); goto 9999 - end if - current%next => newnode - newnode%prev => current - newsz = newsz + 1 - newnode%item%parms = medparms - newnode%item%parms%aggr_thresh = & - & (current%item%parms%aggr_thresh)*(current%item%parms%aggr_scale) - call mld_coarse_bld(current%item%base_a, current%item%base_desc, & - & newnode%item,info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='build next level'); goto 9999 - end if - - current => current%next - tail => current - iaggsize = sum(current%item%map%naggr) - - if (iaggsize <= casize) then - ! - ! Target reached; but we may need to rebuild. - ! - exit list_build_loop - end if - if (newsz>2) then - sizeratio = iaggsize - sizeratio = sum(current%prev%item%map%naggr)/sizeratio - - if (sizeratio < mnaggratio) then - if (sizeratio > 1) exit list_build_loop - ! - ! We are not gaining - ! - newsz = newsz-1 - current => current%prev - current%next =>null() - call newnode%item%free(info) - if (info == psb_success_) deallocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 - end if - exit list_build_loop - end if - end if - - end do list_build_loop - ! - ! At this point, we are at the list tail. - ! If the top aggregation parameters were different, then we need to rebuild; - ! the threshold has to be fixed before rebuliding, and the parms must be - ! copied anyway since they'll be used later for the smoother build. - ! - coarseparms%aggr_thresh = current%item%parms%aggr_thresh - - if (.not.mld_equal_aggregation(current%item%parms, coarseparms)) then - ! Need to rebuild. - current%item%parms = coarseparms - call mld_coarse_bld(current%prev%item%base_a,& - & current%prev%item%base_desc, & - & current%item,info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='build next level'); goto 9999 - end if - else - ! Need only copy the parms. - current%item%parms = coarseparms - end if - ! - ! Ok, now allocate the output vector and fix items. - ! - do i=1,iszv - if (info == psb_success_) call precv(i)%free(info) - end do - if (info == psb_success_) deallocate(precv,stat=info) - if (info == psb_success_) allocate(precv(newsz),stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 - end if - newnode => head - do i=1, newsz - current => newnode - ! First do a move_alloc. - ! This handles the AC, DESC_AC and MAP fields - if (info == psb_success_) & - & call current%item%move_alloc(precv(i),info) - ! Now set the smoother/solver parts. - if (info == psb_success_) then - if (i ==1) then - allocate(precv(i)%sm,source=base_sm,stat=info) - if (allocated(base_sm2)) then - allocate(precv(i)%sm2a,source=base_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else if (i < newsz) then - allocate(precv(i)%sm,source=med_sm,stat=info) - if (allocated(med_sm2)) then - allocate(precv(i)%sm2a,source=med_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else - allocate(precv(i)%sm,source=coarse_sm,stat=info) - end if - end if - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='list cpy'); goto 9999 - end if - if (i == 1) then - precv(i)%base_a => a - precv(i)%base_desc => desc_a - else - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end if - - newnode => current%next - deallocate(current) - end do - call base_sm%free(info) - if (info == psb_success_) call med_sm%free(info) - if (info == psb_success_) call coarse_sm%free(info) - if ((info == psb_success_).and.(allocated(base_sm2))) call base_sm2%free(info) - if ((info == psb_success_).and.(allocated(med_sm2))) call med_sm2%free(info) - if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='final cleanup'); goto 9999 - end if - iszv = newsz - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_d_bld_mlhier_aggsize diff --git a/mlprec/impl/mld_d_bld_mlhier_array.f90 b/mlprec/impl/mld_d_bld_mlhier_array.f90 deleted file mode 100644 index 3618de1b..00000000 --- a/mlprec/impl/mld_d_bld_mlhier_array.f90 +++ /dev/null @@ -1,246 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -subroutine mld_d_bld_mlhier_array(nplevs,a,desc_a,precv,info) - use psb_base_mod - use mld_d_inner_mod, mld_protect_name => mld_d_bld_mlhier_array - use mld_d_prec_mod - implicit none - integer(psb_ipk_), intent(inout) :: nplevs - type(psb_dspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_d_onelev_type),intent(inout), allocatable, target :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm - type(mld_dml_parms) :: baseparms, medparms, coarseparms - type(mld_d_onelev_type), allocatable :: tprecv(:) - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_array_hierarchy' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - iszv = size(precv) - - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if (info /= psb_success_) then - write(0,*) 'Error in saving smoothers',info - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - - ! - ! - ! Build the matrix and the transfer operators corresponding - ! to the remaining levels - ! - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,precv(1)%parms) - iszv = size(precv) - ! - ! First set desired number of levels - ! - if (iszv /= nplevs) then - allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - iszv = size(precv) - end if - - ! - ! Finest level first; remember to fix base_a and base_desc - ! - precv(1)%base_a => a - precv(1)%base_desc => desc_a - newsz = 0 - array_build_loop: do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,precv(i)%parms) - - ! - ! Sanity checks on the parameters - ! - if (i= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling mlprcbld at level ',i - ! - ! Build the mapping between levels i-1 and i and the matrix - ! at level i - ! - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, precv(i),info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Init upper level preconditioner') - goto 9999 - endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info - - if (i>2) then - if (all(precv(i)%map%naggr == precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop - end if - end do array_build_loop - - if (newsz > 0) then - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) - end if - allocate(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz-1 - call precv(i)%move_alloc(tprecv(i),info) - end do - call precv(iszv)%move_alloc(tprecv(newsz),info) - do i=newsz+1, iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - ! Ignore errors from transfer - info = psb_success_ - ! - ! Restart - iszv = newsz - ! Fix the pointers, but the level 1 should - ! be already OK - do i=2, iszv - 1 - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end do - - i = iszv - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, precv(i),info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') - goto 9999 - endif - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_d_bld_mlhier_array diff --git a/mlprec/impl/mld_d_hierarchy_bld.f90 b/mlprec/impl/mld_d_hierarchy_bld.f90 index 42a33e94..e8af7fed 100644 --- a/mlprec/impl/mld_d_hierarchy_bld.f90 +++ b/mlprec/impl/mld_d_hierarchy_bld.f90 @@ -62,19 +62,8 @@ ! of the preconditioner to be built. ! info - integer, output. ! Error code. -! -! amold - class(psb_d_base_sparse_mat), input, optional -! Mold for the inner format of matrices contained in the -! preconditioner -! -! -! vmold - class(psb_d_base_vect_type), input, optional -! Mold for the inner format of vectors contained in the -! preconditioner -! -! ! -subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_d_hierarchy_bld(a,desc_a,p,info) use psb_base_mod use mld_d_inner_mod @@ -87,9 +76,6 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) type(psb_desc_type), intent(inout), target :: desc_a type(mld_dprec_type),intent(inout),target :: p integer(psb_ipk_), intent(out) :: info - class(psb_d_base_sparse_mat), intent(in), optional :: amold - class(psb_d_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables @@ -206,11 +192,10 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! 4. If the size of the array is different from target number of levels, ! reallocate; ! 5. Build the matrix hierarchy, stopping early if either the target - ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! coarse size is hit, or the gain falls below the min_aggr_ratio ! threshold. ! - if (nplevs <= 0) then if (casize <=0) then ! diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index ac2f3923..b5252739 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -119,7 +119,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold) & write(debug_unit,*) me,' ',trim(name),& & 'Entering ' - call mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_d_hierarchy_bld(a,desc_a,p,info) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_s_bld_mlhier_aggsize.f90 b/mlprec/impl/mld_s_bld_mlhier_aggsize.f90 deleted file mode 100644 index 9be3473c..00000000 --- a/mlprec/impl/mld_s_bld_mlhier_aggsize.f90 +++ /dev/null @@ -1,268 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Build an aggregation hierarchy with a target aggregation size -! -! -subroutine mld_s_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) - use psb_base_mod - use mld_s_inner_mod, mld_protect_name => mld_s_bld_mlhier_aggsize - use mld_s_prec_mod - implicit none - integer(psb_ipk_), intent(in) :: casize,mxplevs - real(psb_spk_) :: mnaggratio - type(psb_sspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_s_onelev_type), allocatable, target, intent(inout) :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, iaggsize - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - integer(psb_ipk_) :: int_err(5) - character :: upd_ - class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2 - type(mld_sml_parms) :: baseparms, medparms, coarseparms - type(mld_s_onelev_node), pointer :: head, tail, newnode, current - real(psb_spk_) :: sizeratio - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_mlhier_aggsize' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - ! - ! New strategy to build according to coarse size. - ! - iszv = size(precv) - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if ((info == psb_success_).and.allocated(precv(1)%sm2a)) & - & allocate(base_sm2, source=precv(1)%sm2a,stat=info) - if ((info == psb_success_).and.allocated(precv(2)%sm2a)) & - & allocate(med_sm2, source=precv(2)%sm2a,stat=info) - if (info /= psb_success_) then - write(0,*) 'Error in saving smoothers',info - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - ! - ! Replicated matrix should only ever happen at coarse level. - ! - call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& - & mld_distr_mat_,is_distr_ml_coarse_mat) - ! - ! Now build a doubly linked list - ! - allocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='List start'); goto 9999 - end if - head => newnode - tail => newnode - newnode%item%base_a => a - newnode%item%base_desc => desc_a - newnode%item%parms = baseparms - newsz = 1 - current => head - list_build_loop: do - allocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='List start'); goto 9999 - end if - current%next => newnode - newnode%prev => current - newsz = newsz + 1 - newnode%item%parms = medparms - newnode%item%parms%aggr_thresh = & - & (current%item%parms%aggr_thresh)*(current%item%parms%aggr_scale) - call mld_coarse_bld(current%item%base_a, current%item%base_desc, & - & newnode%item,info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='build next level'); goto 9999 - end if - - current => current%next - tail => current - iaggsize = sum(current%item%map%naggr) - - if (iaggsize <= casize) then - ! - ! Target reached; but we may need to rebuild. - ! - exit list_build_loop - end if - if (newsz>2) then - sizeratio = iaggsize - sizeratio = sum(current%prev%item%map%naggr)/sizeratio - - if (sizeratio < mnaggratio) then - if (sizeratio > 1) exit list_build_loop - ! - ! We are not gaining - ! - newsz = newsz-1 - current => current%prev - current%next =>null() - call newnode%item%free(info) - if (info == psb_success_) deallocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 - end if - exit list_build_loop - end if - end if - - end do list_build_loop - ! - ! At this point, we are at the list tail. - ! If the top aggregation parameters were different, then we need to rebuild; - ! the threshold has to be fixed before rebuliding, and the parms must be - ! copied anyway since they'll be used later for the smoother build. - ! - coarseparms%aggr_thresh = current%item%parms%aggr_thresh - - if (.not.mld_equal_aggregation(current%item%parms, coarseparms)) then - ! Need to rebuild. - current%item%parms = coarseparms - call mld_coarse_bld(current%prev%item%base_a,& - & current%prev%item%base_desc, & - & current%item,info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='build next level'); goto 9999 - end if - else - ! Need only copy the parms. - current%item%parms = coarseparms - end if - ! - ! Ok, now allocate the output vector and fix items. - ! - do i=1,iszv - if (info == psb_success_) call precv(i)%free(info) - end do - if (info == psb_success_) deallocate(precv,stat=info) - if (info == psb_success_) allocate(precv(newsz),stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 - end if - newnode => head - do i=1, newsz - current => newnode - ! First do a move_alloc. - ! This handles the AC, DESC_AC and MAP fields - if (info == psb_success_) & - & call current%item%move_alloc(precv(i),info) - ! Now set the smoother/solver parts. - if (info == psb_success_) then - if (i ==1) then - allocate(precv(i)%sm,source=base_sm,stat=info) - if (allocated(base_sm2)) then - allocate(precv(i)%sm2a,source=base_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else if (i < newsz) then - allocate(precv(i)%sm,source=med_sm,stat=info) - if (allocated(med_sm2)) then - allocate(precv(i)%sm2a,source=med_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else - allocate(precv(i)%sm,source=coarse_sm,stat=info) - end if - end if - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='list cpy'); goto 9999 - end if - if (i == 1) then - precv(i)%base_a => a - precv(i)%base_desc => desc_a - else - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end if - - newnode => current%next - deallocate(current) - end do - call base_sm%free(info) - if (info == psb_success_) call med_sm%free(info) - if (info == psb_success_) call coarse_sm%free(info) - if ((info == psb_success_).and.(allocated(base_sm2))) call base_sm2%free(info) - if ((info == psb_success_).and.(allocated(med_sm2))) call med_sm2%free(info) - if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='final cleanup'); goto 9999 - end if - iszv = newsz - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_s_bld_mlhier_aggsize diff --git a/mlprec/impl/mld_s_bld_mlhier_array.f90 b/mlprec/impl/mld_s_bld_mlhier_array.f90 deleted file mode 100644 index 3f249d34..00000000 --- a/mlprec/impl/mld_s_bld_mlhier_array.f90 +++ /dev/null @@ -1,246 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -subroutine mld_s_bld_mlhier_array(nplevs,a,desc_a,precv,info) - use psb_base_mod - use mld_s_inner_mod, mld_protect_name => mld_s_bld_mlhier_array - use mld_s_prec_mod - implicit none - integer(psb_ipk_), intent(inout) :: nplevs - type(psb_sspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_s_onelev_type),intent(inout), allocatable, target :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm - type(mld_sml_parms) :: baseparms, medparms, coarseparms - type(mld_s_onelev_type), allocatable :: tprecv(:) - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_array_hierarchy' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - iszv = size(precv) - - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if (info /= psb_success_) then - write(0,*) 'Error in saving smoothers',info - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - - ! - ! - ! Build the matrix and the transfer operators corresponding - ! to the remaining levels - ! - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,precv(1)%parms) - iszv = size(precv) - ! - ! First set desired number of levels - ! - if (iszv /= nplevs) then - allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - iszv = size(precv) - end if - - ! - ! Finest level first; remember to fix base_a and base_desc - ! - precv(1)%base_a => a - precv(1)%base_desc => desc_a - newsz = 0 - array_build_loop: do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,precv(i)%parms) - - ! - ! Sanity checks on the parameters - ! - if (i= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling mlprcbld at level ',i - ! - ! Build the mapping between levels i-1 and i and the matrix - ! at level i - ! - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, precv(i),info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Init upper level preconditioner') - goto 9999 - endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info - - if (i>2) then - if (all(precv(i)%map%naggr == precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop - end if - end do array_build_loop - - if (newsz > 0) then - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) - end if - allocate(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz-1 - call precv(i)%move_alloc(tprecv(i),info) - end do - call precv(iszv)%move_alloc(tprecv(newsz),info) - do i=newsz+1, iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - ! Ignore errors from transfer - info = psb_success_ - ! - ! Restart - iszv = newsz - ! Fix the pointers, but the level 1 should - ! be already OK - do i=2, iszv - 1 - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end do - - i = iszv - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, precv(i),info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') - goto 9999 - endif - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_s_bld_mlhier_array diff --git a/mlprec/impl/mld_s_hierarchy_bld.f90 b/mlprec/impl/mld_s_hierarchy_bld.f90 index 3faf3f57..acd8aa53 100644 --- a/mlprec/impl/mld_s_hierarchy_bld.f90 +++ b/mlprec/impl/mld_s_hierarchy_bld.f90 @@ -62,19 +62,8 @@ ! of the preconditioner to be built. ! info - integer, output. ! Error code. -! -! amold - class(psb_s_base_sparse_mat), input, optional -! Mold for the inner format of matrices contained in the -! preconditioner -! -! -! vmold - class(psb_s_base_vect_type), input, optional -! Mold for the inner format of vectors contained in the -! preconditioner -! -! ! -subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_s_hierarchy_bld(a,desc_a,p,info) use psb_base_mod use mld_s_inner_mod @@ -87,9 +76,6 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) type(psb_desc_type), intent(inout), target :: desc_a type(mld_sprec_type),intent(inout),target :: p integer(psb_ipk_), intent(out) :: info - class(psb_s_base_sparse_mat), intent(in), optional :: amold - class(psb_s_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables @@ -206,11 +192,10 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! 4. If the size of the array is different from target number of levels, ! reallocate; ! 5. Build the matrix hierarchy, stopping early if either the target - ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! coarse size is hit, or the gain falls below the min_aggr_ratio ! threshold. ! - if (nplevs <= 0) then if (casize <=0) then ! diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index 8f9d4502..b96dc733 100644 --- a/mlprec/impl/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -119,7 +119,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold) & write(debug_unit,*) me,' ',trim(name),& & 'Entering ' - call mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_s_hierarchy_bld(a,desc_a,p,info) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/impl/mld_z_bld_mlhier_aggsize.f90 b/mlprec/impl/mld_z_bld_mlhier_aggsize.f90 deleted file mode 100644 index 9ae5da74..00000000 --- a/mlprec/impl/mld_z_bld_mlhier_aggsize.f90 +++ /dev/null @@ -1,268 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Build an aggregation hierarchy with a target aggregation size -! -! -subroutine mld_z_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) - use psb_base_mod - use mld_z_inner_mod, mld_protect_name => mld_z_bld_mlhier_aggsize - use mld_z_prec_mod - implicit none - integer(psb_ipk_), intent(in) :: casize,mxplevs - real(psb_dpk_) :: mnaggratio - type(psb_zspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_z_onelev_type), allocatable, target, intent(inout) :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, iaggsize - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - integer(psb_ipk_) :: int_err(5) - character :: upd_ - class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2 - type(mld_dml_parms) :: baseparms, medparms, coarseparms - type(mld_z_onelev_node), pointer :: head, tail, newnode, current - real(psb_dpk_) :: sizeratio - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_mlhier_aggsize' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - ! - ! New strategy to build according to coarse size. - ! - iszv = size(precv) - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if ((info == psb_success_).and.allocated(precv(1)%sm2a)) & - & allocate(base_sm2, source=precv(1)%sm2a,stat=info) - if ((info == psb_success_).and.allocated(precv(2)%sm2a)) & - & allocate(med_sm2, source=precv(2)%sm2a,stat=info) - if (info /= psb_success_) then - write(0,*) 'Error in saving smoothers',info - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - ! - ! Replicated matrix should only ever happen at coarse level. - ! - call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& - & mld_distr_mat_,is_distr_ml_coarse_mat) - ! - ! Now build a doubly linked list - ! - allocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='List start'); goto 9999 - end if - head => newnode - tail => newnode - newnode%item%base_a => a - newnode%item%base_desc => desc_a - newnode%item%parms = baseparms - newsz = 1 - current => head - list_build_loop: do - allocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='List start'); goto 9999 - end if - current%next => newnode - newnode%prev => current - newsz = newsz + 1 - newnode%item%parms = medparms - newnode%item%parms%aggr_thresh = & - & (current%item%parms%aggr_thresh)*(current%item%parms%aggr_scale) - call mld_coarse_bld(current%item%base_a, current%item%base_desc, & - & newnode%item,info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='build next level'); goto 9999 - end if - - current => current%next - tail => current - iaggsize = sum(current%item%map%naggr) - - if (iaggsize <= casize) then - ! - ! Target reached; but we may need to rebuild. - ! - exit list_build_loop - end if - if (newsz>2) then - sizeratio = iaggsize - sizeratio = sum(current%prev%item%map%naggr)/sizeratio - - if (sizeratio < mnaggratio) then - if (sizeratio > 1) exit list_build_loop - ! - ! We are not gaining - ! - newsz = newsz-1 - current => current%prev - current%next =>null() - call newnode%item%free(info) - if (info == psb_success_) deallocate(newnode,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 - end if - exit list_build_loop - end if - end if - - end do list_build_loop - ! - ! At this point, we are at the list tail. - ! If the top aggregation parameters were different, then we need to rebuild; - ! the threshold has to be fixed before rebuliding, and the parms must be - ! copied anyway since they'll be used later for the smoother build. - ! - coarseparms%aggr_thresh = current%item%parms%aggr_thresh - - if (.not.mld_equal_aggregation(current%item%parms, coarseparms)) then - ! Need to rebuild. - current%item%parms = coarseparms - call mld_coarse_bld(current%prev%item%base_a,& - & current%prev%item%base_desc, & - & current%item,info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='build next level'); goto 9999 - end if - else - ! Need only copy the parms. - current%item%parms = coarseparms - end if - ! - ! Ok, now allocate the output vector and fix items. - ! - do i=1,iszv - if (info == psb_success_) call precv(i)%free(info) - end do - if (info == psb_success_) deallocate(precv,stat=info) - if (info == psb_success_) allocate(precv(newsz),stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 - end if - newnode => head - do i=1, newsz - current => newnode - ! First do a move_alloc. - ! This handles the AC, DESC_AC and MAP fields - if (info == psb_success_) & - & call current%item%move_alloc(precv(i),info) - ! Now set the smoother/solver parts. - if (info == psb_success_) then - if (i ==1) then - allocate(precv(i)%sm,source=base_sm,stat=info) - if (allocated(base_sm2)) then - allocate(precv(i)%sm2a,source=base_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else if (i < newsz) then - allocate(precv(i)%sm,source=med_sm,stat=info) - if (allocated(med_sm2)) then - allocate(precv(i)%sm2a,source=med_sm2,stat=info) - precv(i)%sm2 => precv(i)%sm2a - else - precv(i)%sm2 => precv(i)%sm - end if - else - allocate(precv(i)%sm,source=coarse_sm,stat=info) - end if - end if - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='list cpy'); goto 9999 - end if - if (i == 1) then - precv(i)%base_a => a - precv(i)%base_desc => desc_a - else - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end if - - newnode => current%next - deallocate(current) - end do - call base_sm%free(info) - if (info == psb_success_) call med_sm%free(info) - if (info == psb_success_) call coarse_sm%free(info) - if ((info == psb_success_).and.(allocated(base_sm2))) call base_sm2%free(info) - if ((info == psb_success_).and.(allocated(med_sm2))) call med_sm2%free(info) - if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) - if (info /= psb_success_) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='final cleanup'); goto 9999 - end if - iszv = newsz - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_z_bld_mlhier_aggsize diff --git a/mlprec/impl/mld_z_bld_mlhier_array.f90 b/mlprec/impl/mld_z_bld_mlhier_array.f90 deleted file mode 100644 index 206cdf30..00000000 --- a/mlprec/impl/mld_z_bld_mlhier_array.f90 +++ /dev/null @@ -1,246 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) -!!$ -!!$ (C) Copyright 2008, 2010, 2012, 2015 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -subroutine mld_z_bld_mlhier_array(nplevs,a,desc_a,precv,info) - use psb_base_mod - use mld_z_inner_mod, mld_protect_name => mld_z_bld_mlhier_array - use mld_z_prec_mod - implicit none - integer(psb_ipk_), intent(inout) :: nplevs - type(psb_zspmat_type),intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a - type(mld_z_onelev_type),intent(inout), allocatable, target :: precv(:) - integer(psb_ipk_), intent(out) :: info - ! Local - integer(psb_ipk_) :: ictxt, me,np - integer(psb_ipk_) :: err,i,k, err_act, newsz, iszv - integer(psb_ipk_) :: ipv(mld_ifpsz_), val - class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm - type(mld_dml_parms) :: baseparms, medparms, coarseparms - type(mld_z_onelev_type), allocatable :: tprecv(:) - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err - name = 'mld_bld_array_hierarchy' - if (psb_get_errstatus().ne.0) return - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) - iszv = size(precv) - - coarseparms = precv(iszv)%parms - baseparms = precv(1)%parms - medparms = precv(2)%parms - - allocate(coarse_sm, source=precv(iszv)%sm,stat=info) - if (info == psb_success_) & - & allocate(med_sm, source=precv(2)%sm,stat=info) - if (info == psb_success_) & - & allocate(base_sm, source=precv(1)%sm,stat=info) - if (info /= psb_success_) then - write(0,*) 'Error in saving smoothers',info - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - - ! - ! - ! Build the matrix and the transfer operators corresponding - ! to the remaining levels - ! - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,precv(1)%parms) - iszv = size(precv) - ! - ! First set desired number of levels - ! - if (iszv /= nplevs) then - allocate(tprecv(nplevs),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - tprecv(1)%parms = baseparms - allocate(tprecv(1)%sm,source=base_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=2,nplevs-1 - tprecv(i)%parms = medparms - allocate(tprecv(i)%sm,source=med_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - end do - tprecv(nplevs)%parms = coarseparms - allocate(tprecv(nplevs)%sm,source=coarse_sm,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - iszv = size(precv) - end if - - ! - ! Finest level first; remember to fix base_a and base_desc - ! - precv(1)%base_a => a - precv(1)%base_desc => desc_a - newsz = 0 - array_build_loop: do i=2, iszv - ! - ! Check on the iprcparm contents: they should be the same - ! on all processes. - ! - call psb_bcast(ictxt,precv(i)%parms) - - ! - ! Sanity checks on the parameters - ! - if (i= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling mlprcbld at level ',i - ! - ! Build the mapping between levels i-1 and i and the matrix - ! at level i - ! - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, precv(i),info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Init upper level preconditioner') - goto 9999 - endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Return from ',i,' call to mlprcbld ',info - - if (i>2) then - if (all(precv(i)%map%naggr == precv(i-1)%map%naggr)) then - newsz=i-1 - end if - call psb_bcast(ictxt,newsz) - if (newsz > 0) exit array_build_loop - end if - end do array_build_loop - - if (newsz > 0) then - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) - end if - allocate(tprecv(newsz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,& - & a_err='prec reallocation') - goto 9999 - endif - do i=1,newsz-1 - call precv(i)%move_alloc(tprecv(i),info) - end do - call precv(iszv)%move_alloc(tprecv(newsz),info) - do i=newsz+1, iszv - call precv(i)%free(info) - end do - call move_alloc(tprecv,precv) - ! Ignore errors from transfer - info = psb_success_ - ! - ! Restart - iszv = newsz - ! Fix the pointers, but the level 1 should - ! be already OK - do i=2, iszv - 1 - precv(i)%base_a => precv(i)%ac - precv(i)%base_desc => precv(i)%desc_ac - precv(i)%map%p_desc_X => precv(i-1)%base_desc - precv(i)%map%p_desc_Y => precv(i)%base_desc - end do - - i = iszv - if (info == psb_success_) call mld_coarse_bld(precv(i-1)%base_a,& - & precv(i-1)%base_desc, precv(i),info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='coarse rebuild') - goto 9999 - endif - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine mld_z_bld_mlhier_array diff --git a/mlprec/impl/mld_z_hierarchy_bld.f90 b/mlprec/impl/mld_z_hierarchy_bld.f90 index 47689ee5..33982c77 100644 --- a/mlprec/impl/mld_z_hierarchy_bld.f90 +++ b/mlprec/impl/mld_z_hierarchy_bld.f90 @@ -62,19 +62,8 @@ ! of the preconditioner to be built. ! info - integer, output. ! Error code. -! -! amold - class(psb_z_base_sparse_mat), input, optional -! Mold for the inner format of matrices contained in the -! preconditioner -! -! -! vmold - class(psb_z_base_vect_type), input, optional -! Mold for the inner format of vectors contained in the -! preconditioner -! -! ! -subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) +subroutine mld_z_hierarchy_bld(a,desc_a,p,info) use psb_base_mod use mld_z_inner_mod @@ -87,9 +76,6 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) type(psb_desc_type), intent(inout), target :: desc_a type(mld_zprec_type),intent(inout),target :: p integer(psb_ipk_), intent(out) :: info - class(psb_z_base_sparse_mat), intent(in), optional :: amold - class(psb_z_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables @@ -206,11 +192,10 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) ! 4. If the size of the array is different from target number of levels, ! reallocate; ! 5. Build the matrix hierarchy, stopping early if either the target - ! coarse size is hit, or the gain fall below the mmin_aggr_ratio + ! coarse size is hit, or the gain falls below the min_aggr_ratio ! threshold. ! - if (nplevs <= 0) then if (casize <=0) then ! diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index b1532029..7c292b1c 100644 --- a/mlprec/impl/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -119,7 +119,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold) & write(debug_unit,*) me,' ',trim(name),& & 'Entering ' - call mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold) + call mld_z_hierarchy_bld(a,desc_a,p,info) if (info /= psb_success_) then info=psb_err_internal_error_ diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index 5d0fea10..103d66c5 100644 --- a/mlprec/mld_c_prec_mod.f90 +++ b/mlprec/mld_c_prec_mod.f90 @@ -88,18 +88,14 @@ module mld_c_prec_mod end interface mld_precbld interface mld_hierarchy_bld - subroutine mld_c_hierarchy_bld(a,desc_a,prec,info,amold,vmold,imold) + subroutine mld_c_hierarchy_bld(a,desc_a,prec,info) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & - & psb_c_base_sparse_mat, psb_c_base_vect_type, & - & psb_i_base_vect_type, mld_cprec_type, psb_ipk_ + & mld_cprec_type, psb_ipk_ implicit none type(psb_cspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_cprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info - class(psb_c_base_sparse_mat), intent(in), optional :: amold - class(psb_c_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd end subroutine mld_c_hierarchy_bld end interface mld_hierarchy_bld diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index 25a6ba3c..6e8de542 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -88,18 +88,14 @@ module mld_d_prec_mod end interface mld_precbld interface mld_hierarchy_bld - subroutine mld_d_hierarchy_bld(a,desc_a,prec,info,amold,vmold,imold) + subroutine mld_d_hierarchy_bld(a,desc_a,prec,info) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & - & psb_d_base_sparse_mat, psb_d_base_vect_type, & - & psb_i_base_vect_type, mld_dprec_type, psb_ipk_ + & mld_dprec_type, psb_ipk_ implicit none type(psb_dspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_dprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info - class(psb_d_base_sparse_mat), intent(in), optional :: amold - class(psb_d_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd end subroutine mld_d_hierarchy_bld end interface mld_hierarchy_bld diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index da3d546d..b7b4ddc9 100644 --- a/mlprec/mld_s_prec_mod.f90 +++ b/mlprec/mld_s_prec_mod.f90 @@ -88,18 +88,14 @@ module mld_s_prec_mod end interface mld_precbld interface mld_hierarchy_bld - subroutine mld_s_hierarchy_bld(a,desc_a,prec,info,amold,vmold,imold) + subroutine mld_s_hierarchy_bld(a,desc_a,prec,info) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & - & psb_s_base_sparse_mat, psb_s_base_vect_type, & - & psb_i_base_vect_type, mld_sprec_type, psb_ipk_ + & mld_sprec_type, psb_ipk_ implicit none type(psb_sspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_sprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info - class(psb_s_base_sparse_mat), intent(in), optional :: amold - class(psb_s_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd end subroutine mld_s_hierarchy_bld end interface mld_hierarchy_bld diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index cd1aa321..1d2f203f 100644 --- a/mlprec/mld_z_prec_mod.f90 +++ b/mlprec/mld_z_prec_mod.f90 @@ -88,18 +88,14 @@ module mld_z_prec_mod end interface mld_precbld interface mld_hierarchy_bld - subroutine mld_z_hierarchy_bld(a,desc_a,prec,info,amold,vmold,imold) + subroutine mld_z_hierarchy_bld(a,desc_a,prec,info) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & - & psb_z_base_sparse_mat, psb_z_base_vect_type, & - & psb_i_base_vect_type, mld_zprec_type, psb_ipk_ + & mld_zprec_type, psb_ipk_ implicit none type(psb_zspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a type(mld_zprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info - class(psb_z_base_sparse_mat), intent(in), optional :: amold - class(psb_z_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold ! character, intent(in),optional :: upd end subroutine mld_z_hierarchy_bld end interface mld_hierarchy_bld