fdurastante
/
amg4psblas
mirror of https://github.com/sfilippone/amg4psblas.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

mld2p4-2:

Browse Source 
Changelog
 mlprec/impl/Makefile
 mlprec/impl/mld_c_bld_mlhier_aggsize.f90
 mlprec/impl/mld_c_bld_mlhier_array.f90
 mlprec/impl/mld_c_dec_map_bld.f90
 mlprec/impl/mld_c_hierarchy_bld.f90
 mlprec/impl/mld_c_lev_aggrmap_bld.f90
 mlprec/impl/mld_c_lev_aggrmat_asb.f90
 mlprec/impl/mld_c_ml_prec_bld.f90
 mlprec/impl/mld_c_smoothers_bld.f90
 mlprec/impl/mld_caggrmap_bld.f90
 mlprec/impl/mld_caggrmat_asb.f90
 mlprec/impl/mld_caggrmat_biz_asb.f90
 mlprec/impl/mld_caggrmat_minnrg_asb.f90
 mlprec/impl/mld_caggrmat_nosmth_asb.f90
 mlprec/impl/mld_caggrmat_smth_asb.f90
 mlprec/impl/mld_ccprecset.F90
 mlprec/impl/mld_cmlprec_bld.f90
 mlprec/impl/mld_cprecinit.F90
 mlprec/impl/mld_d_bld_mlhier_aggsize.f90
 mlprec/impl/mld_d_bld_mlhier_array.f90
 mlprec/impl/mld_d_dec_map_bld.f90
 mlprec/impl/mld_d_hierarchy_bld.f90
 mlprec/impl/mld_d_lev_aggrmap_bld.f90
 mlprec/impl/mld_d_lev_aggrmat_asb.f90
 mlprec/impl/mld_d_ml_prec_bld.f90
 mlprec/impl/mld_d_smoothers_bld.f90
 mlprec/impl/mld_daggrmap_bld.f90
 mlprec/impl/mld_daggrmat_asb.f90
 mlprec/impl/mld_daggrmat_biz_asb.f90
 mlprec/impl/mld_daggrmat_minnrg_asb.f90
 mlprec/impl/mld_daggrmat_nosmth_asb.f90
 mlprec/impl/mld_daggrmat_smth_asb.f90
 mlprec/impl/mld_dcprecset.F90
 mlprec/impl/mld_dmlprec_bld.f90
 mlprec/impl/mld_dprecinit.F90
 mlprec/impl/mld_s_bld_mlhier_aggsize.f90
 mlprec/impl/mld_s_bld_mlhier_array.f90
 mlprec/impl/mld_s_dec_map_bld.f90
 mlprec/impl/mld_s_hierarchy_bld.f90
 mlprec/impl/mld_s_lev_aggrmap_bld.f90
 mlprec/impl/mld_s_lev_aggrmat_asb.f90
 mlprec/impl/mld_s_ml_prec_bld.f90
 mlprec/impl/mld_s_smoothers_bld.f90
 mlprec/impl/mld_saggrmap_bld.f90
 mlprec/impl/mld_saggrmat_asb.f90
 mlprec/impl/mld_saggrmat_biz_asb.f90
 mlprec/impl/mld_saggrmat_minnrg_asb.f90
 mlprec/impl/mld_saggrmat_nosmth_asb.f90
 mlprec/impl/mld_saggrmat_smth_asb.f90
 mlprec/impl/mld_scprecset.F90
 mlprec/impl/mld_smlprec_bld.f90
 mlprec/impl/mld_sprecinit.F90
 mlprec/impl/mld_z_bld_mlhier_aggsize.f90
 mlprec/impl/mld_z_bld_mlhier_array.f90
 mlprec/impl/mld_z_dec_map_bld.f90
 mlprec/impl/mld_z_hierarchy_bld.f90
 mlprec/impl/mld_z_lev_aggrmap_bld.f90
 mlprec/impl/mld_z_lev_aggrmat_asb.f90
 mlprec/impl/mld_z_ml_prec_bld.f90
 mlprec/impl/mld_z_smoothers_bld.f90
 mlprec/impl/mld_zaggrmap_bld.f90
 mlprec/impl/mld_zaggrmat_asb.f90
 mlprec/impl/mld_zaggrmat_biz_asb.f90
 mlprec/impl/mld_zaggrmat_minnrg_asb.f90
 mlprec/impl/mld_zaggrmat_nosmth_asb.f90
 mlprec/impl/mld_zaggrmat_smth_asb.f90
 mlprec/impl/mld_zcprecset.F90
 mlprec/impl/mld_zmlprec_bld.f90
 mlprec/impl/mld_zprecinit.F90
 mlprec/mld_base_prec_type.F90
 mlprec/mld_c_inner_mod.f90
 mlprec/mld_c_prec_mod.f90
 mlprec/mld_d_inner_mod.f90
 mlprec/mld_d_prec_mod.f90
 mlprec/mld_s_inner_mod.f90
 mlprec/mld_s_prec_mod.f90
 mlprec/mld_z_inner_mod.f90
 mlprec/mld_z_prec_mod.f90
 tests/pdegen/mld_d_pde2d.f90
 tests/pdegen/mld_d_pde3d.f90
 tests/pdegen/mld_s_pde2d.f90
 tests/pdegen/mld_s_pde3d.f90
 tests/pdegen/runs/ppde.inp

Merged changes from extaggr-branch: reworked hierarchy build.
stopcriterion
Salvatore Filippone 10 years ago
parent 0898738486 bc8ba9bb8a
commit 2c19839666
80 changed files with 3303 additions and 3469 deletions
Show Stats Download Patch File Download Diff File

4
Changelog
Unescape Escape View File

@ -1,5 +1,9 @@
Changelog. A lot less detailed than usual, at least for past Changelog. A lot less detailed than usual, at least for past
history. 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 2016/05/18: Reworked internals of PRECSET. Defined Forward-Backward
Gauss-Seidel solver. Now available separate PRE and POST smoother Gauss-Seidel solver. Now available separate PRE and POST smoother
objects. objects.

24
mlprec/impl/Makefile
Unescape Escape View File

@ -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 MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o
DINNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_d_bld_mlhier_aggsize.o mld_d_bld_mlhier_array.o \ DINNEROBJS= mld_dmlprec_bld.o \
mld_d_ml_prec_bld.o mld_d_hierarchy_bld.o \ mld_d_smoothers_bld.o mld_d_hierarchy_bld.o \
mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \ mld_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 \ 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 \ SINNEROBJS= mld_smlprec_bld.o \
mld_s_ml_prec_bld.o mld_s_hierarchy_bld.o \ mld_s_smoothers_bld.o mld_s_hierarchy_bld.o \
mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o mld_saggrmap_bld.o \ mld_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 \ 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 \ ZINNEROBJS= mld_zmlprec_bld.o \
mld_z_ml_prec_bld.o mld_z_hierarchy_bld.o \ mld_z_smoothers_bld.o mld_z_hierarchy_bld.o \
mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \ mld_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 \ 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 \ CINNEROBJS= mld_cmlprec_bld.o \
mld_c_ml_prec_bld.o mld_c_hierarchy_bld.o \ mld_c_smoothers_bld.o mld_c_hierarchy_bld.o \
mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \ mld_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 \ 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) INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS)

268
mlprec/impl/mld_c_bld_mlhier_aggsize.f90
Unescape Escape View File

@ -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

246
mlprec/impl/mld_c_bld_mlhier_array.f90
Unescape Escape View File

@ -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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
!
if (info == psb_success_) call mld_coarse_bld(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

16
mlprec/impl/mld_c_dec_map_bld.f90
Unescape Escape View File

@ -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 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 type(psb_c_csr_sparse_mat) :: acsr
real(psb_spk_) :: cpling, tcl real(psb_spk_) :: cpling, tcl
logical :: recovery, disjoint logical :: disjoint
integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne 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
end if end if
enddo 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 ! 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 if (disjoint) then
icnt = icnt + 1 icnt = icnt + 1
naggr = naggr + 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 step3: do ii=1,nr
i = idxs(ii) i = idxs(ii)
if (ilaggr(i) < 0) then if (ilaggr(i) < 0) then
call a%csget(i,i,nz,irow,icol,val,info) call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ 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 ! Find its strongly connected neighbourhood not
! already aggregated, and make it into a new aggregate. ! already aggregated, and make it into a new aggregate.
! !
cpling = szero cpling = dzero
ip = 0 ip = 0
do k=1, nz do k=1, nz
j = icol(k) j = icol(k)

291
mlprec/impl/mld_c_hierarchy_bld.f90
Unescape Escape View File

@ -62,19 +62,8 @@
! of the preconditioner to be built. ! of the preconditioner to be built.
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_c_inner_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(psb_desc_type), intent(inout), target :: desc_a
type(mld_cprec_type),intent(inout),target :: p type(mld_cprec_type),intent(inout),target :: p
integer(psb_ipk_), intent(out) :: info 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 !!$ character, intent(in), optional :: upd
! Local Variables ! Local Variables
integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_spk_) :: mnaggratio real(psb_spk_) :: mnaggratio, sizeratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val 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) integer(psb_ipk_) :: int_err(5)
character :: upd_ character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit 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 goto 9999
endif 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 if (nplevs <= 0) then
!
! This should become the default strategy, we specify a target aggregation size.
!
if (casize <=0) then if (casize <=0) then
! !
! Default to the cubic root of the size at base level. ! 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 = max(casize,ione)
casize = casize*40_psb_ipk_ casize = casize*40_psb_ipk_
end if end if
call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info) nplevs = mxplevs
else 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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
! !
! 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)) ! Check for early termination of aggregation loop.
call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info) !
end if 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 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' ) & a_err='Internal hierarchy build' )
@ -220,7 +401,7 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
endif endif
iszv = size(p%precv) iszv = size(p%precv)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels' & 'Exiting with',iszv,' levels'
@ -232,4 +413,58 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
return 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 end subroutine mld_c_hierarchy_bld

148
mlprec/impl/mld_c_lev_aggrmap_bld.f90
Unescape Escape View File

@ -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

252
mlprec/impl/mld_c_lev_aggrmat_asb.f90
Unescape Escape View File

@ -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

12
mlprec/impl/mld_c_ml_prec_bld.f90 → mlprec/impl/mld_c_smoothers_bld.f90
Unescape Escape View File

@ -36,9 +36,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 ! Version: complex
! !
! This routine builds the preconditioner according to the requirements made by ! 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 psb_base_mod
use mld_c_inner_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 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_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
name = 'mld_c_ml_prec_bld' name = 'mld_c_smoothers_bld'
info = psb_success_ info = psb_success_
int_err(1) = 0 int_err(1) = 0
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
@ -191,4 +191,4 @@ subroutine mld_c_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
return return
end subroutine mld_c_ml_prec_bld end subroutine mld_c_smoothers_bld

29
mlprec/impl/mld_caggrmap_bld.f90
Unescape Escape View File

@ -79,7 +79,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_c_inner_mod, mld_protect_name => mld_caggrmap_bld 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_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_cspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_), allocatable :: ils(:), neigh(:) 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 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_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne 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 goto 9999
end if 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) call psb_erractionrestore(err_act)
return return

126
mlprec/impl/mld_caggrmat_asb.f90
Unescape Escape View File

@ -98,7 +98,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_c_inner_mod, mld_protect_name => mld_caggrmat_asb 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_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
type(psb_cspmat_type) :: ac, op_prol,op_restr
type(psb_c_coo_sparse_mat) :: acoo, bcoo type(psb_c_coo_sparse_mat) :: acoo, bcoo
type(psb_c_csr_sparse_mat) :: acsr1 type(psb_c_csr_sparse_mat) :: acsr1
integer(psb_ipk_) :: nzl,ntaggr, err_act 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) call psb_info(ictxt, me, np)
select case (p%parms%aggr_kind) select case (parms%aggr_kind)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& 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_) case(mld_smooth_prol_)
call mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & 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_) case(mld_biz_prol_)
call mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & 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_) case(mld_min_energy_)
call mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & 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 case default
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -165,116 +165,6 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999 goto 9999
end if 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) call psb_erractionrestore(err_act)
return return

39
mlprec/impl/mld_caggrmat_biz_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from_coo(tmpcoo,info) call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) 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_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
end if end if

42
mlprec/impl/mld_caggrmat_minnrg_asb.f90
Unescape Escape View File

@ -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_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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_) 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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from(tmpcoo) call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') 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(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_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then 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) call am3%mv_to(acsr3)
! Compute omega_int ! Compute omega_int
ommx = cmplx(szero,szero) ommx = czero
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
! !
! Build the smoothed prolongator using the filtered matrix ! 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 omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int ! Compute omega_int
ommx = cmplx(szero,szero) ommx = czero
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)

31
mlprec/impl/mld_caggrmat_nosmth_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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) ntaggr = sum(nlaggr)
naggrm1=sum(nlaggr(1:me)) 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) 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_) 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) call a%cp_to(ac_coo)
nzt = ac_coo%get_nzeros() nzt = ac_coo%get_nzeros()

37
mlprec/impl/mld_caggrmat_smth_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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)) naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 !
call psb_halo(ilaggr,desc_a,info)
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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from_coo(tmpcoo,info) call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) 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_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
end if end if

1
mlprec/impl/mld_ccprecset.F90
Unescape Escape View File

@ -519,7 +519,6 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev,pos)
ilev_=nlev_ ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE') case('AGGR_SCALE')
do ilev_ = 2, nlev_ do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos) call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)

4
mlprec/impl/mld_cmlprec_bld.f90
Unescape Escape View File

@ -119,7 +119,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Entering ' & '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 if (info /= psb_success_) then
info=psb_err_internal_error_ 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() 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 if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_

2
mlprec/impl/mld_cprecinit.F90
Unescape Escape View File

@ -207,7 +207,7 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
do ilev_=1,nlev_ do ilev_=1,nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) 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_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 end do
case default case default

268
mlprec/impl/mld_d_bld_mlhier_aggsize.f90
Unescape Escape View File

@ -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

246
mlprec/impl/mld_d_bld_mlhier_array.f90
Unescape Escape View File

@ -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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
!
if (info == psb_success_) call mld_coarse_bld(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

14
mlprec/impl/mld_d_dec_map_bld.f90
Unescape Escape View File

@ -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 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 type(psb_d_csr_sparse_mat) :: acsr
real(psb_dpk_) :: cpling, tcl real(psb_dpk_) :: cpling, tcl
logical :: recovery, disjoint logical :: disjoint
integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne 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
end if end if
enddo 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 ! 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 if (disjoint) then
icnt = icnt + 1 icnt = icnt + 1
naggr = naggr + 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 step3: do ii=1,nr
i = idxs(ii) i = idxs(ii)
if (ilaggr(i) < 0) then if (ilaggr(i) < 0) then
call a%csget(i,i,nz,irow,icol,val,info) call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_

291
mlprec/impl/mld_d_hierarchy_bld.f90
Unescape Escape View File

@ -62,19 +62,8 @@
! of the preconditioner to be built. ! of the preconditioner to be built.
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_d_inner_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(psb_desc_type), intent(inout), target :: desc_a
type(mld_dprec_type),intent(inout),target :: p type(mld_dprec_type),intent(inout),target :: p
integer(psb_ipk_), intent(out) :: info 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 !!$ character, intent(in), optional :: upd
! Local Variables ! Local Variables
integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_dpk_) :: mnaggratio real(psb_dpk_) :: mnaggratio, sizeratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val 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) integer(psb_ipk_) :: int_err(5)
character :: upd_ character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit 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 goto 9999
endif 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 if (nplevs <= 0) then
!
! This should become the default strategy, we specify a target aggregation size.
!
if (casize <=0) then if (casize <=0) then
! !
! Default to the cubic root of the size at base level. ! 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 = max(casize,ione)
casize = casize*40_psb_ipk_ casize = casize*40_psb_ipk_
end if end if
call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info) nplevs = mxplevs
else 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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
! !
! 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)) ! Check for early termination of aggregation loop.
call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info) !
end if 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 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' ) & a_err='Internal hierarchy build' )
@ -220,7 +401,7 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
endif endif
iszv = size(p%precv) iszv = size(p%precv)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels' & 'Exiting with',iszv,' levels'
@ -232,4 +413,58 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
return 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 end subroutine mld_d_hierarchy_bld

148
mlprec/impl/mld_d_lev_aggrmap_bld.f90
Unescape Escape View File

@ -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

252
mlprec/impl/mld_d_lev_aggrmat_asb.f90
Unescape Escape View File

@ -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

12
mlprec/impl/mld_d_ml_prec_bld.f90 → mlprec/impl/mld_d_smoothers_bld.f90
Unescape Escape View File

@ -36,9 +36,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 ! Version: real
! !
! This routine builds the preconditioner according to the requirements made by ! 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 psb_base_mod
use mld_d_inner_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 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_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
name = 'mld_d_ml_prec_bld' name = 'mld_d_smoothers_bld'
info = psb_success_ info = psb_success_
int_err(1) = 0 int_err(1) = 0
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
@ -191,4 +191,4 @@ subroutine mld_d_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
return return
end subroutine mld_d_ml_prec_bld end subroutine mld_d_smoothers_bld

29
mlprec/impl/mld_daggrmap_bld.f90
Unescape Escape View File

@ -79,7 +79,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_d_inner_mod, mld_protect_name => mld_daggrmap_bld 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_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_dspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_), allocatable :: ils(:), neigh(:) 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 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_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne 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 goto 9999
end if 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) call psb_erractionrestore(err_act)
return return

126
mlprec/impl/mld_daggrmat_asb.f90
Unescape Escape View File

@ -98,7 +98,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_asb 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_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
type(psb_dspmat_type) :: ac, op_prol,op_restr
type(psb_d_coo_sparse_mat) :: acoo, bcoo type(psb_d_coo_sparse_mat) :: acoo, bcoo
type(psb_d_csr_sparse_mat) :: acsr1 type(psb_d_csr_sparse_mat) :: acsr1
integer(psb_ipk_) :: nzl,ntaggr, err_act 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) call psb_info(ictxt, me, np)
select case (p%parms%aggr_kind) select case (parms%aggr_kind)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& 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_) case(mld_smooth_prol_)
call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & 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_) case(mld_biz_prol_)
call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & 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_) case(mld_min_energy_)
call mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & 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 case default
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -165,116 +165,6 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999 goto 9999
end if 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) call psb_erractionrestore(err_act)
return return

39
mlprec/impl/mld_daggrmat_biz_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from_coo(tmpcoo,info) call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) 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_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
end if end if

42
mlprec/impl/mld_daggrmat_minnrg_asb.f90
Unescape Escape View File

@ -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_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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_) 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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from(tmpcoo) call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') 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(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_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then 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) call am3%mv_to(acsr3)
! Compute omega_int ! Compute omega_int
ommx = cmplx(dzero,dzero) ommx = dzero
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
! !
! Build the smoothed prolongator using the filtered matrix ! 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 omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int ! Compute omega_int
ommx = cmplx(dzero,dzero) ommx = dzero
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)

31
mlprec/impl/mld_daggrmat_nosmth_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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) ntaggr = sum(nlaggr)
naggrm1=sum(nlaggr(1:me)) 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) 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_) 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) call a%cp_to(ac_coo)
nzt = ac_coo%get_nzeros() nzt = ac_coo%get_nzeros()

37
mlprec/impl/mld_daggrmat_smth_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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)) naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 !
call psb_halo(ilaggr,desc_a,info)
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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from_coo(tmpcoo,info) call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) 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_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
end if end if

1
mlprec/impl/mld_dcprecset.F90
Unescape Escape View File

@ -529,7 +529,6 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev,pos)
ilev_=nlev_ ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE') case('AGGR_SCALE')
do ilev_ = 2, nlev_ do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos) call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)

4
mlprec/impl/mld_dmlprec_bld.f90
Unescape Escape View File

@ -119,7 +119,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Entering ' & '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 if (info /= psb_success_) then
info=psb_err_internal_error_ 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() 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 if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_

2
mlprec/impl/mld_dprecinit.F90
Unescape Escape View File

@ -212,7 +212,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
do ilev_=1,nlev_ do ilev_=1,nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) 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_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 end do
case default case default

268
mlprec/impl/mld_s_bld_mlhier_aggsize.f90
Unescape Escape View File

@ -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

246
mlprec/impl/mld_s_bld_mlhier_array.f90
Unescape Escape View File

@ -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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
!
if (info == psb_success_) call mld_coarse_bld(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

16
mlprec/impl/mld_s_dec_map_bld.f90
Unescape Escape View File

@ -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 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 type(psb_s_csr_sparse_mat) :: acsr
real(psb_spk_) :: cpling, tcl real(psb_spk_) :: cpling, tcl
logical :: recovery, disjoint logical :: disjoint
integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne 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
end if end if
enddo 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 ! 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 if (disjoint) then
icnt = icnt + 1 icnt = icnt + 1
naggr = naggr + 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 step3: do ii=1,nr
i = idxs(ii) i = idxs(ii)
if (ilaggr(i) < 0) then if (ilaggr(i) < 0) then
call a%csget(i,i,nz,irow,icol,val,info) call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ 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 ! Find its strongly connected neighbourhood not
! already aggregated, and make it into a new aggregate. ! already aggregated, and make it into a new aggregate.
! !
cpling = szero cpling = dzero
ip = 0 ip = 0
do k=1, nz do k=1, nz
j = icol(k) j = icol(k)

291
mlprec/impl/mld_s_hierarchy_bld.f90
Unescape Escape View File

@ -62,19 +62,8 @@
! of the preconditioner to be built. ! of the preconditioner to be built.
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_s_inner_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(psb_desc_type), intent(inout), target :: desc_a
type(mld_sprec_type),intent(inout),target :: p type(mld_sprec_type),intent(inout),target :: p
integer(psb_ipk_), intent(out) :: info 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 !!$ character, intent(in), optional :: upd
! Local Variables ! Local Variables
integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_spk_) :: mnaggratio real(psb_spk_) :: mnaggratio, sizeratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val 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) integer(psb_ipk_) :: int_err(5)
character :: upd_ character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit 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 goto 9999
endif 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 if (nplevs <= 0) then
!
! This should become the default strategy, we specify a target aggregation size.
!
if (casize <=0) then if (casize <=0) then
! !
! Default to the cubic root of the size at base level. ! 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 = max(casize,ione)
casize = casize*40_psb_ipk_ casize = casize*40_psb_ipk_
end if end if
call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info) nplevs = mxplevs
else 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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
! !
! 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)) ! Check for early termination of aggregation loop.
call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info) !
end if 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 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' ) & a_err='Internal hierarchy build' )
@ -220,7 +401,7 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
endif endif
iszv = size(p%precv) iszv = size(p%precv)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels' & 'Exiting with',iszv,' levels'
@ -232,4 +413,58 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
return 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 end subroutine mld_s_hierarchy_bld

148
mlprec/impl/mld_s_lev_aggrmap_bld.f90
Unescape Escape View File

@ -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

252
mlprec/impl/mld_s_lev_aggrmat_asb.f90
Unescape Escape View File

@ -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

12
mlprec/impl/mld_s_ml_prec_bld.f90 → mlprec/impl/mld_s_smoothers_bld.f90
Unescape Escape View File

@ -36,9 +36,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 ! Version: real
! !
! This routine builds the preconditioner according to the requirements made by ! 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 psb_base_mod
use mld_s_inner_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 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_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
name = 'mld_s_ml_prec_bld' name = 'mld_s_smoothers_bld'
info = psb_success_ info = psb_success_
int_err(1) = 0 int_err(1) = 0
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
@ -191,4 +191,4 @@ subroutine mld_s_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
return return
end subroutine mld_s_ml_prec_bld end subroutine mld_s_smoothers_bld

29
mlprec/impl/mld_saggrmap_bld.f90
Unescape Escape View File

@ -79,7 +79,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_s_inner_mod, mld_protect_name => mld_saggrmap_bld 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_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_sspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_), allocatable :: ils(:), neigh(:) 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 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_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne 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 goto 9999
end if 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) call psb_erractionrestore(err_act)
return return

126
mlprec/impl/mld_saggrmat_asb.f90
Unescape Escape View File

@ -98,7 +98,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_s_inner_mod, mld_protect_name => mld_saggrmat_asb 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_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
type(psb_sspmat_type) :: ac, op_prol,op_restr
type(psb_s_coo_sparse_mat) :: acoo, bcoo type(psb_s_coo_sparse_mat) :: acoo, bcoo
type(psb_s_csr_sparse_mat) :: acsr1 type(psb_s_csr_sparse_mat) :: acsr1
integer(psb_ipk_) :: nzl,ntaggr, err_act 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) call psb_info(ictxt, me, np)
select case (p%parms%aggr_kind) select case (parms%aggr_kind)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& 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_) case(mld_smooth_prol_)
call mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & 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_) case(mld_biz_prol_)
call mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & 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_) case(mld_min_energy_)
call mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & 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 case default
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -165,116 +165,6 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999 goto 9999
end if 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) call psb_erractionrestore(err_act)
return return

39
mlprec/impl/mld_saggrmat_biz_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from_coo(tmpcoo,info) call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) 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_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
end if end if

42
mlprec/impl/mld_saggrmat_minnrg_asb.f90
Unescape Escape View File

@ -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_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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_) 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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from(tmpcoo) call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') 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(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_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then 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) call am3%mv_to(acsr3)
! Compute omega_int ! Compute omega_int
ommx = cmplx(szero,szero) ommx = szero
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
! !
! Build the smoothed prolongator using the filtered matrix ! 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 omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int ! Compute omega_int
ommx = cmplx(szero,szero) ommx = szero
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)

31
mlprec/impl/mld_saggrmat_nosmth_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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) ntaggr = sum(nlaggr)
naggrm1=sum(nlaggr(1:me)) 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) 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_) 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) call a%cp_to(ac_coo)
nzt = ac_coo%get_nzeros() nzt = ac_coo%get_nzeros()

37
mlprec/impl/mld_saggrmat_smth_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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)) naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 !
call psb_halo(ilaggr,desc_a,info)
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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from_coo(tmpcoo,info) call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) 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_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
end if end if

1
mlprec/impl/mld_scprecset.F90
Unescape Escape View File

@ -519,7 +519,6 @@ subroutine mld_scprecsetr(p,what,val,info,ilev,pos)
ilev_=nlev_ ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE') case('AGGR_SCALE')
do ilev_ = 2, nlev_ do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos) call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)

4
mlprec/impl/mld_smlprec_bld.f90
Unescape Escape View File

@ -119,7 +119,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Entering ' & '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 if (info /= psb_success_) then
info=psb_err_internal_error_ 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() 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 if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_

2
mlprec/impl/mld_sprecinit.F90
Unescape Escape View File

@ -207,7 +207,7 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
do ilev_=1,nlev_ do ilev_=1,nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) 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_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 end do
case default case default

268
mlprec/impl/mld_z_bld_mlhier_aggsize.f90
Unescape Escape View File

@ -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

246
mlprec/impl/mld_z_bld_mlhier_array.f90
Unescape Escape View File

@ -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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
!
if (info == psb_success_) call mld_coarse_bld(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

14
mlprec/impl/mld_z_dec_map_bld.f90
Unescape Escape View File

@ -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 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 type(psb_z_csr_sparse_mat) :: acsr
real(psb_dpk_) :: cpling, tcl real(psb_dpk_) :: cpling, tcl
logical :: recovery, disjoint logical :: disjoint
integer(psb_ipk_) :: debug_level, debug_unit,err_act integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne 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
end if end if
enddo 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 ! 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 if (disjoint) then
icnt = icnt + 1 icnt = icnt + 1
naggr = naggr + 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 step3: do ii=1,nr
i = idxs(ii) i = idxs(ii)
if (ilaggr(i) < 0) then if (ilaggr(i) < 0) then
call a%csget(i,i,nz,irow,icol,val,info) call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_

291
mlprec/impl/mld_z_hierarchy_bld.f90
Unescape Escape View File

@ -62,19 +62,8 @@
! of the preconditioner to be built. ! of the preconditioner to be built.
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_z_inner_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(psb_desc_type), intent(inout), target :: desc_a
type(mld_zprec_type),intent(inout),target :: p type(mld_zprec_type),intent(inout),target :: p
integer(psb_ipk_), intent(out) :: info 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 !!$ character, intent(in), optional :: upd
! Local Variables ! Local Variables
integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_dpk_) :: mnaggratio real(psb_dpk_) :: mnaggratio, sizeratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val 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) integer(psb_ipk_) :: int_err(5)
character :: upd_ character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit 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 goto 9999
endif 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 if (nplevs <= 0) then
!
! This should become the default strategy, we specify a target aggregation size.
!
if (casize <=0) then if (casize <=0) then
! !
! Default to the cubic root of the size at base level. ! 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 = max(casize,ione)
casize = casize*40_psb_ipk_ casize = casize*40_psb_ipk_
end if end if
call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info) nplevs = mxplevs
else 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<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the mapping between levels i-1 and i and the matrix
! at level i
! !
! 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)) ! Check for early termination of aggregation loop.
call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info) !
end if 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 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' ) & a_err='Internal hierarchy build' )
@ -220,7 +401,7 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
endif endif
iszv = size(p%precv) iszv = size(p%precv)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels' & 'Exiting with',iszv,' levels'
@ -232,4 +413,58 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
return 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 end subroutine mld_z_hierarchy_bld

148
mlprec/impl/mld_z_lev_aggrmap_bld.f90
Unescape Escape View File

@ -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

252
mlprec/impl/mld_z_lev_aggrmat_asb.f90
Unescape Escape View File

@ -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

12
mlprec/impl/mld_z_ml_prec_bld.f90 → mlprec/impl/mld_z_smoothers_bld.f90
Unescape Escape View File

@ -36,9 +36,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 ! Version: complex
! !
! This routine builds the preconditioner according to the requirements made by ! 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 psb_base_mod
use mld_z_inner_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 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_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
name = 'mld_z_ml_prec_bld' name = 'mld_z_smoothers_bld'
info = psb_success_ info = psb_success_
int_err(1) = 0 int_err(1) = 0
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
@ -191,4 +191,4 @@ subroutine mld_z_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
return return
end subroutine mld_z_ml_prec_bld end subroutine mld_z_smoothers_bld

29
mlprec/impl/mld_zaggrmap_bld.f90
Unescape Escape View File

@ -79,7 +79,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_z_inner_mod, mld_protect_name => mld_zaggrmap_bld 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_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_zspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_), allocatable :: ils(:), neigh(:) 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 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_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne 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 goto 9999
end if 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) call psb_erractionrestore(err_act)
return return

126
mlprec/impl/mld_zaggrmat_asb.f90
Unescape Escape View File

@ -98,7 +98,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! 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 psb_base_mod
use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_asb 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_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
type(psb_zspmat_type) :: ac, op_prol,op_restr
type(psb_z_coo_sparse_mat) :: acoo, bcoo type(psb_z_coo_sparse_mat) :: acoo, bcoo
type(psb_z_csr_sparse_mat) :: acsr1 type(psb_z_csr_sparse_mat) :: acsr1
integer(psb_ipk_) :: nzl,ntaggr, err_act 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) call psb_info(ictxt, me, np)
select case (p%parms%aggr_kind) select case (parms%aggr_kind)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& 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_) case(mld_smooth_prol_)
call mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & 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_) case(mld_biz_prol_)
call mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & 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_) case(mld_min_energy_)
call mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & 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 case default
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -165,116 +165,6 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999 goto 9999
end if 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) call psb_erractionrestore(err_act)
return return

39
mlprec/impl/mld_zaggrmat_biz_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from_coo(tmpcoo,info) call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) 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_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
end if end if

42
mlprec/impl/mld_zaggrmat_minnrg_asb.f90
Unescape Escape View File

@ -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_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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_) 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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from(tmpcoo) call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') 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(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_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then 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) call am3%mv_to(acsr3)
! Compute omega_int ! Compute omega_int
ommx = cmplx(dzero,dzero) ommx = zzero
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
! !
! Build the smoothed prolongator using the filtered matrix ! 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 omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int ! Compute omega_int
ommx = cmplx(dzero,dzero) ommx = zzero
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)

31
mlprec/impl/mld_zaggrmat_nosmth_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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) ntaggr = sum(nlaggr)
naggrm1=sum(nlaggr(1:me)) 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) 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_) 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) call a%cp_to(ac_coo)
nzt = ac_coo%get_nzeros() nzt = ac_coo%get_nzeros()

37
mlprec/impl/mld_zaggrmat_smth_asb.f90
Unescape Escape View File

@ -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 type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms 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 integer(psb_ipk_), intent(out) :: info
! Local variables ! 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)) naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 !
call psb_halo(ilaggr,desc_a,info)
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 ! naggr: number of local aggregates
! nrow: local rows. ! 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 end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol) call op_prol%mv_to(tmpcoo)
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 ptilde%mv_from_coo(tmpcoo,info) call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) 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_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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 end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info) call acsrf%clean_zeros(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)
end if end if

1
mlprec/impl/mld_zcprecset.F90
Unescape Escape View File

@ -529,7 +529,6 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev,pos)
ilev_=nlev_ ilev_=nlev_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE') case('AGGR_SCALE')
do ilev_ = 2, nlev_ do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos) call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)

4
mlprec/impl/mld_zmlprec_bld.f90
Unescape Escape View File

@ -119,7 +119,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Entering ' & '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 if (info /= psb_success_) then
info=psb_err_internal_error_ 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() 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 if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_

2
mlprec/impl/mld_zprecinit.F90
Unescape Escape View File

@ -212,7 +212,7 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
do ilev_=1,nlev_ do ilev_=1,nlev_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) 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_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 end do
case default case default

31
mlprec/mld_base_prec_type.F90
Unescape Escape View File

@ -86,14 +86,14 @@ module mld_base_prec_type
integer(psb_ipk_), parameter :: mld_patchlevel_ = 0 integer(psb_ipk_), parameter :: mld_patchlevel_ = 0
type mld_aux_onelev_map_type !!$ type mld_aux_onelev_map_type
integer(psb_ipk_) :: naggr !!$ integer(psb_ipk_) :: naggr
integer(psb_ipk_), allocatable :: ilaggr(:) !!$ integer(psb_ipk_), allocatable :: ilaggr(:)
end type mld_aux_onelev_map_type !!$ end type mld_aux_onelev_map_type
!!$
type mld_aux_map_type !!$ type mld_aux_map_type
type(mld_aux_onelev_map_type), allocatable :: mapv(:) !!$ type(mld_aux_onelev_map_type), allocatable :: mapv(:)
end type mld_aux_map_type !!$ end type mld_aux_map_type
type mld_ml_parms type mld_ml_parms
integer(psb_ipk_) :: sweeps, sweeps_pre, sweeps_post 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_dec_aggr_ = 0
integer(psb_ipk_), parameter :: mld_sym_dec_aggr_ = 1 integer(psb_ipk_), parameter :: mld_sym_dec_aggr_ = 1
integer(psb_ipk_), parameter :: mld_ext_aggr_ = 2 integer(psb_ipk_), parameter :: mld_bcmatch_aggr_ = 2
integer(psb_ipk_), parameter :: mld_glb_aggr_ = 3 integer(psb_ipk_), parameter :: mld_ext_aggr_ = 3
integer(psb_ipk_), parameter :: mld_new_dec_aggr_ = 4 integer(psb_ipk_), parameter :: mld_glb_aggr_ = 4
integer(psb_ipk_), parameter :: mld_new_glb_aggr_ = 5 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_ integer(psb_ipk_), parameter :: mld_max_aggr_alg_ = mld_ext_aggr_
! !
! Legal values for entry: mld_aggr_ord_ ! Legal values for entry: mld_aggr_ord_
@ -338,8 +339,8 @@ module mld_base_prec_type
character(len=15), parameter, private :: & character(len=15), parameter, private :: &
& matrix_names(0:1)=(/'distributed ','replicated '/) & matrix_names(0:1)=(/'distributed ','replicated '/)
character(len=18), parameter, private :: & character(len=18), parameter, private :: &
& aggr_names(0:5)=(/'local aggregation ','sym. local aggr. ',& & aggr_names(0:6)=(/'local aggregation ','sym. local aggr. ',&
& 'user defined aggr.', 'global aggregation', & & 'bootchmatch aggr. ','user defined aggr.', 'global aggregation', &
& 'new local aggr. ','new global aggr. '/) & 'new local aggr. ','new global aggr. '/)
character(len=18), parameter, private :: & character(len=18), parameter, private :: &
& ord_names(0:1)=(/'Natural ordering ','Desc. degree ord. '/) & ord_names(0:1)=(/'Natural ordering ','Desc. degree ord. '/)
@ -453,6 +454,8 @@ contains
val = mld_dec_aggr_ val = mld_dec_aggr_
case('SYMDEC') case('SYMDEC')
val = mld_sym_dec_aggr_ val = mld_sym_dec_aggr_
case('BCMATCH')
val = mld_bcmatch_aggr_
case('NAT','NATURAL') case('NAT','NATURAL')
val = mld_aggr_ord_nat_ val = mld_aggr_ord_nat_
case('DESC','RDEGREE','DEGREE') case('DESC','RDEGREE','DEGREE')

57
mlprec/mld_c_inner_mod.f90
Unescape Escape View File

@ -64,7 +64,6 @@ module mld_c_inner_mod
end subroutine mld_cmlprec_bld end subroutine mld_cmlprec_bld
end interface mld_mlprec_bld end interface mld_mlprec_bld
interface mld_mlprec_aply interface mld_mlprec_aply
subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) 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_ 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 subroutine mld_cmlprec_aply_vect
end interface mld_mlprec_aply 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 interface mld_bld_mlhier_aggsize
subroutine mld_c_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) 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_ 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 end interface mld_bld_mlhier_aggsize
interface mld_bld_mlhier_array interface mld_bld_mlhier_array
subroutine mld_c_bld_mlhier_array(nplevs,a,desc_a,precv,info) subroutine mld_c_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_c_onelev_type use mld_c_prec_type, only : mld_c_onelev_type
implicit none 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_cspmat_type),intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a type(psb_desc_type), intent(inout), target :: desc_a
type(mld_c_onelev_type), allocatable, target, intent(inout) :: precv(:) 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 end interface mld_bld_mlhier_array
interface mld_aggrmap_bld 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_ use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_
implicit none implicit none
integer(psb_ipk_), intent(in) :: iorder integer(psb_ipk_), intent(in) :: iorder
@ -146,6 +143,7 @@ module mld_c_inner_mod
type(psb_cspmat_type), intent(in) :: a type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_cspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine mld_caggrmap_bld end subroutine mld_caggrmap_bld
end interface mld_aggrmap_bld end interface mld_aggrmap_bld
@ -165,15 +163,30 @@ module mld_c_inner_mod
end interface mld_dec_map_bld end interface mld_dec_map_bld
interface mld_aggrmat_asb interface mld_lev_mat_asb
subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) 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 psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_c_prec_type, only : mld_c_onelev_type use mld_c_prec_type, only : mld_c_onelev_type
implicit none 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_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) 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 integer(psb_ipk_), intent(out) :: info
end subroutine mld_caggrmat_asb end subroutine mld_caggrmat_asb
end interface mld_aggrmat_asb end interface mld_aggrmat_asb

16
mlprec/mld_c_prec_mod.f90
Unescape Escape View File

@ -88,18 +88,14 @@ module mld_c_prec_mod
end interface mld_precbld end interface mld_precbld
interface mld_hierarchy_bld 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_, & import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& psb_c_base_sparse_mat, psb_c_base_vect_type, & & mld_cprec_type, psb_ipk_
& psb_i_base_vect_type, mld_cprec_type, psb_ipk_
implicit none implicit none
type(psb_cspmat_type), intent(in), target :: a type(psb_cspmat_type), intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a type(psb_desc_type), intent(inout), target :: desc_a
type(mld_cprec_type), intent(inout), target :: prec type(mld_cprec_type), intent(inout), target :: prec
integer(psb_ipk_), intent(out) :: info 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 ! character, intent(in),optional :: upd
end subroutine mld_c_hierarchy_bld end subroutine mld_c_hierarchy_bld
end interface mld_hierarchy_bld end interface mld_hierarchy_bld
@ -124,8 +120,8 @@ module mld_c_prec_mod
end subroutine mld_c_extprol_bld end subroutine mld_c_extprol_bld
end interface mld_extprol_bld end interface mld_extprol_bld
interface mld_ml_prec_bld interface mld_smoothers_bld
subroutine mld_c_ml_prec_bld(a,desc_a,prec,info,amold,vmold,imold) subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, & import :: psb_cspmat_type, psb_desc_type, psb_spk_, &
& psb_c_base_sparse_mat, psb_c_base_vect_type, & & psb_c_base_sparse_mat, psb_c_base_vect_type, &
& psb_i_base_vect_type, mld_cprec_type, psb_ipk_ & 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_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold class(psb_i_base_vect_type), intent(in), optional :: imold
! character, intent(in),optional :: upd ! character, intent(in),optional :: upd
end subroutine mld_c_ml_prec_bld end subroutine mld_c_smoothers_bld
end interface mld_ml_prec_bld end interface mld_smoothers_bld
contains contains

57
mlprec/mld_d_inner_mod.f90
Unescape Escape View File

@ -64,7 +64,6 @@ module mld_d_inner_mod
end subroutine mld_dmlprec_bld end subroutine mld_dmlprec_bld
end interface mld_mlprec_bld end interface mld_mlprec_bld
interface mld_mlprec_aply interface mld_mlprec_aply
subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) 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_ 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 subroutine mld_dmlprec_aply_vect
end interface mld_mlprec_aply 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 interface mld_bld_mlhier_aggsize
subroutine mld_d_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) 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_ 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 end interface mld_bld_mlhier_aggsize
interface mld_bld_mlhier_array interface mld_bld_mlhier_array
subroutine mld_d_bld_mlhier_array(nplevs,a,desc_a,precv,info) subroutine mld_d_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_d_onelev_type use mld_d_prec_type, only : mld_d_onelev_type
implicit none 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_dspmat_type),intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a type(psb_desc_type), intent(inout), target :: desc_a
type(mld_d_onelev_type), allocatable, target, intent(inout) :: precv(:) 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 end interface mld_bld_mlhier_array
interface mld_aggrmap_bld 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_ use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
implicit none implicit none
integer(psb_ipk_), intent(in) :: iorder integer(psb_ipk_), intent(in) :: iorder
@ -146,6 +143,7 @@ module mld_d_inner_mod
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_dspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine mld_daggrmap_bld end subroutine mld_daggrmap_bld
end interface mld_aggrmap_bld end interface mld_aggrmap_bld
@ -165,15 +163,30 @@ module mld_d_inner_mod
end interface mld_dec_map_bld end interface mld_dec_map_bld
interface mld_aggrmat_asb interface mld_lev_mat_asb
subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) 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 psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_d_prec_type, only : mld_d_onelev_type use mld_d_prec_type, only : mld_d_onelev_type
implicit none 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_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) 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 integer(psb_ipk_), intent(out) :: info
end subroutine mld_daggrmat_asb end subroutine mld_daggrmat_asb
end interface mld_aggrmat_asb end interface mld_aggrmat_asb

16
mlprec/mld_d_prec_mod.f90
Unescape Escape View File

@ -88,18 +88,14 @@ module mld_d_prec_mod
end interface mld_precbld end interface mld_precbld
interface mld_hierarchy_bld 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_, & import :: psb_dspmat_type, psb_desc_type, psb_dpk_, &
& psb_d_base_sparse_mat, psb_d_base_vect_type, & & mld_dprec_type, psb_ipk_
& psb_i_base_vect_type, mld_dprec_type, psb_ipk_
implicit none implicit none
type(psb_dspmat_type), intent(in), target :: a type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a type(psb_desc_type), intent(inout), target :: desc_a
type(mld_dprec_type), intent(inout), target :: prec type(mld_dprec_type), intent(inout), target :: prec
integer(psb_ipk_), intent(out) :: info 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 ! character, intent(in),optional :: upd
end subroutine mld_d_hierarchy_bld end subroutine mld_d_hierarchy_bld
end interface mld_hierarchy_bld end interface mld_hierarchy_bld
@ -124,8 +120,8 @@ module mld_d_prec_mod
end subroutine mld_d_extprol_bld end subroutine mld_d_extprol_bld
end interface mld_extprol_bld end interface mld_extprol_bld
interface mld_ml_prec_bld interface mld_smoothers_bld
subroutine mld_d_ml_prec_bld(a,desc_a,prec,info,amold,vmold,imold) subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & import :: psb_dspmat_type, psb_desc_type, psb_dpk_, &
& psb_d_base_sparse_mat, psb_d_base_vect_type, & & psb_d_base_sparse_mat, psb_d_base_vect_type, &
& psb_i_base_vect_type, mld_dprec_type, psb_ipk_ & 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_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold class(psb_i_base_vect_type), intent(in), optional :: imold
! character, intent(in),optional :: upd ! character, intent(in),optional :: upd
end subroutine mld_d_ml_prec_bld end subroutine mld_d_smoothers_bld
end interface mld_ml_prec_bld end interface mld_smoothers_bld
contains contains

57
mlprec/mld_s_inner_mod.f90
Unescape Escape View File

@ -64,7 +64,6 @@ module mld_s_inner_mod
end subroutine mld_smlprec_bld end subroutine mld_smlprec_bld
end interface mld_mlprec_bld end interface mld_mlprec_bld
interface mld_mlprec_aply interface mld_mlprec_aply
subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) 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_ 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 subroutine mld_smlprec_aply_vect
end interface mld_mlprec_aply 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 interface mld_bld_mlhier_aggsize
subroutine mld_s_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) 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_ 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 end interface mld_bld_mlhier_aggsize
interface mld_bld_mlhier_array interface mld_bld_mlhier_array
subroutine mld_s_bld_mlhier_array(nplevs,a,desc_a,precv,info) subroutine mld_s_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_s_onelev_type use mld_s_prec_type, only : mld_s_onelev_type
implicit none 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_sspmat_type),intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a type(psb_desc_type), intent(inout), target :: desc_a
type(mld_s_onelev_type), allocatable, target, intent(inout) :: precv(:) 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 end interface mld_bld_mlhier_array
interface mld_aggrmap_bld 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_ use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_
implicit none implicit none
integer(psb_ipk_), intent(in) :: iorder integer(psb_ipk_), intent(in) :: iorder
@ -146,6 +143,7 @@ module mld_s_inner_mod
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_sspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine mld_saggrmap_bld end subroutine mld_saggrmap_bld
end interface mld_aggrmap_bld end interface mld_aggrmap_bld
@ -165,15 +163,30 @@ module mld_s_inner_mod
end interface mld_dec_map_bld end interface mld_dec_map_bld
interface mld_aggrmat_asb interface mld_lev_mat_asb
subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) 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 psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_s_prec_type, only : mld_s_onelev_type use mld_s_prec_type, only : mld_s_onelev_type
implicit none 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_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) 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 integer(psb_ipk_), intent(out) :: info
end subroutine mld_saggrmat_asb end subroutine mld_saggrmat_asb
end interface mld_aggrmat_asb end interface mld_aggrmat_asb

16
mlprec/mld_s_prec_mod.f90
Unescape Escape View File

@ -88,18 +88,14 @@ module mld_s_prec_mod
end interface mld_precbld end interface mld_precbld
interface mld_hierarchy_bld 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_, & import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& psb_s_base_sparse_mat, psb_s_base_vect_type, & & mld_sprec_type, psb_ipk_
& psb_i_base_vect_type, mld_sprec_type, psb_ipk_
implicit none implicit none
type(psb_sspmat_type), intent(in), target :: a type(psb_sspmat_type), intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a type(psb_desc_type), intent(inout), target :: desc_a
type(mld_sprec_type), intent(inout), target :: prec type(mld_sprec_type), intent(inout), target :: prec
integer(psb_ipk_), intent(out) :: info 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 ! character, intent(in),optional :: upd
end subroutine mld_s_hierarchy_bld end subroutine mld_s_hierarchy_bld
end interface mld_hierarchy_bld end interface mld_hierarchy_bld
@ -124,8 +120,8 @@ module mld_s_prec_mod
end subroutine mld_s_extprol_bld end subroutine mld_s_extprol_bld
end interface mld_extprol_bld end interface mld_extprol_bld
interface mld_ml_prec_bld interface mld_smoothers_bld
subroutine mld_s_ml_prec_bld(a,desc_a,prec,info,amold,vmold,imold) subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, & import :: psb_sspmat_type, psb_desc_type, psb_spk_, &
& psb_s_base_sparse_mat, psb_s_base_vect_type, & & psb_s_base_sparse_mat, psb_s_base_vect_type, &
& psb_i_base_vect_type, mld_sprec_type, psb_ipk_ & 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_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold class(psb_i_base_vect_type), intent(in), optional :: imold
! character, intent(in),optional :: upd ! character, intent(in),optional :: upd
end subroutine mld_s_ml_prec_bld end subroutine mld_s_smoothers_bld
end interface mld_ml_prec_bld end interface mld_smoothers_bld
contains contains

57
mlprec/mld_z_inner_mod.f90
Unescape Escape View File

@ -64,7 +64,6 @@ module mld_z_inner_mod
end subroutine mld_zmlprec_bld end subroutine mld_zmlprec_bld
end interface mld_mlprec_bld end interface mld_mlprec_bld
interface mld_mlprec_aply interface mld_mlprec_aply
subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) 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_ 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 subroutine mld_zmlprec_aply_vect
end interface mld_mlprec_aply 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 interface mld_bld_mlhier_aggsize
subroutine mld_z_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info) 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_ 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 end interface mld_bld_mlhier_aggsize
interface mld_bld_mlhier_array interface mld_bld_mlhier_array
subroutine mld_z_bld_mlhier_array(nplevs,a,desc_a,precv,info) subroutine mld_z_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_z_onelev_type use mld_z_prec_type, only : mld_z_onelev_type
implicit none 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_zspmat_type),intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a type(psb_desc_type), intent(inout), target :: desc_a
type(mld_z_onelev_type), allocatable, target, intent(inout) :: precv(:) 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 end interface mld_bld_mlhier_array
interface mld_aggrmap_bld 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_ use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
implicit none implicit none
integer(psb_ipk_), intent(in) :: iorder integer(psb_ipk_), intent(in) :: iorder
@ -146,6 +143,7 @@ module mld_z_inner_mod
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_zspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine mld_zaggrmap_bld end subroutine mld_zaggrmap_bld
end interface mld_aggrmap_bld end interface mld_aggrmap_bld
@ -165,15 +163,30 @@ module mld_z_inner_mod
end interface mld_dec_map_bld end interface mld_dec_map_bld
interface mld_aggrmat_asb interface mld_lev_mat_asb
subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) 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 psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_z_prec_type, only : mld_z_onelev_type use mld_z_prec_type, only : mld_z_onelev_type
implicit none 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_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:) 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 integer(psb_ipk_), intent(out) :: info
end subroutine mld_zaggrmat_asb end subroutine mld_zaggrmat_asb
end interface mld_aggrmat_asb end interface mld_aggrmat_asb

16
mlprec/mld_z_prec_mod.f90
Unescape Escape View File

@ -88,18 +88,14 @@ module mld_z_prec_mod
end interface mld_precbld end interface mld_precbld
interface mld_hierarchy_bld 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_, & import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& psb_z_base_sparse_mat, psb_z_base_vect_type, & & mld_zprec_type, psb_ipk_
& psb_i_base_vect_type, mld_zprec_type, psb_ipk_
implicit none implicit none
type(psb_zspmat_type), intent(in), target :: a type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a type(psb_desc_type), intent(inout), target :: desc_a
type(mld_zprec_type), intent(inout), target :: prec type(mld_zprec_type), intent(inout), target :: prec
integer(psb_ipk_), intent(out) :: info 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 ! character, intent(in),optional :: upd
end subroutine mld_z_hierarchy_bld end subroutine mld_z_hierarchy_bld
end interface mld_hierarchy_bld end interface mld_hierarchy_bld
@ -124,8 +120,8 @@ module mld_z_prec_mod
end subroutine mld_z_extprol_bld end subroutine mld_z_extprol_bld
end interface mld_extprol_bld end interface mld_extprol_bld
interface mld_ml_prec_bld interface mld_smoothers_bld
subroutine mld_z_ml_prec_bld(a,desc_a,prec,info,amold,vmold,imold) subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & import :: psb_zspmat_type, psb_desc_type, psb_dpk_, &
& psb_z_base_sparse_mat, psb_z_base_vect_type, & & psb_z_base_sparse_mat, psb_z_base_vect_type, &
& psb_i_base_vect_type, mld_zprec_type, psb_ipk_ & 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_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold class(psb_i_base_vect_type), intent(in), optional :: imold
! character, intent(in),optional :: upd ! character, intent(in),optional :: upd
end subroutine mld_z_ml_prec_bld end subroutine mld_z_smoothers_bld
end interface mld_ml_prec_bld end interface mld_smoothers_bld
contains contains

47
tests/pdegen/mld_d_pde2d.f90
Unescape Escape View File

@ -1,8 +1,8 @@
!!!$ !!!$
!!$ !!$
!!$ MLD2P4 version 2.0 !!$ MLD2P4 version 2.1
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package !!$ 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 !!$ (C) Copyright 2008, 2010, 2012, 2015
!!$ !!$
@ -69,34 +69,34 @@ contains
! functions parametrizing the differential equation ! functions parametrizing the differential equation
! !
function b1(x,y) 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_) :: b1
real(psb_dpk_), intent(in) :: x,y real(psb_dpk_), intent(in) :: x,y
b1=0.d0/sqrt(2.d0) b1=dzero/sqrt((2*done))
end function b1 end function b1
function b2(x,y) 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_) :: b2
real(psb_dpk_), intent(in) :: x,y real(psb_dpk_), intent(in) :: x,y
b2=0.d0/sqrt(2.d0) b2=dzero/sqrt((2*done))
end function b2 end function b2
function c(x,y) 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_) :: c
real(psb_dpk_), intent(in) :: x,y real(psb_dpk_), intent(in) :: x,y
c=0.d0 c=dzero
end function c end function c
function a1(x,y) 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_) :: a1
real(psb_dpk_), intent(in) :: x,y real(psb_dpk_), intent(in) :: x,y
a1=1.d0!/80 a1=done!/80
end function a1 end function a1
function a2(x,y) 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_) :: a2
real(psb_dpk_), intent(in) :: x,y real(psb_dpk_), intent(in) :: x,y
a2=1.d0!/80 a2=done!/80
end function a2 end function a2
function g(x,y) function g(x,y)
use psb_base_mod, only : psb_dpk_, done, dzero 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) :: aggrkind ! smoothed/raw aggregatin
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: aggr_ord ! Ordering for 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) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer(psb_ipk_) :: csize ! aggregation size at which to stop. integer(psb_ipk_) :: csize ! aggregation size at which to stop.
@ -175,6 +176,8 @@ program mld_d_pde2d
type(precdata) :: prectype type(precdata) :: prectype
type(psb_d_coo_sparse_mat) :: acoo type(psb_d_coo_sparse_mat) :: acoo
! other variables ! other variables
logical :: dump_prec
character(len=40) :: dump_prefix
integer(psb_ipk_) :: info, i integer(psb_ipk_) :: info, i
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
@ -203,7 +206,8 @@ program mld_d_pde2d
! !
! get parameters ! 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 ! 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_kind', prectype%aggrkind,info)
call mld_precset(prec,'aggr_alg', prectype%aggr_alg,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_ord', prectype%aggr_ord,info)
call mld_precset(prec,'aggr_filter', prectype%aggr_filter, info)
call psb_barrier(ictxt) call psb_barrier(ictxt)
t1 = psb_wtime() t1 = psb_wtime()
@ -368,6 +373,10 @@ program mld_d_pde2d
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize
end if 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 ! cleanup storage and exit
! !
@ -392,13 +401,17 @@ contains
! !
! get iteration parameters from standard input ! 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 integer(psb_ipk_) :: ictxt
type(precdata) :: prectype type(precdata) :: prectype
character(len=*) :: kmethd, afmt character(len=*) :: kmethd, afmt
integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst
integer(psb_ipk_) :: np, iam, info integer(psb_ipk_) :: np, iam, info
real(psb_dpk_) :: eps real(psb_dpk_) :: eps
logical :: dump_prec
character(len=*) :: dump_prefix
character(len=20) :: buffer character(len=20) :: buffer
call psb_info(ictxt, iam, np) call psb_info(ictxt, iam, np)
@ -412,6 +425,8 @@ contains
call read_data(itrace,psb_inp_unit) call read_data(itrace,psb_inp_unit)
call read_data(irst,psb_inp_unit) call read_data(irst,psb_inp_unit)
call read_data(eps,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%descr,psb_inp_unit) ! verbose description of the prec
call read_data(prectype%prec,psb_inp_unit) ! overall prectype call read_data(prectype%prec,psb_inp_unit) ! overall prectype
call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels 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%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_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_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%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%smthpos,psb_inp_unit) ! side: pre, post, both smoothing
call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps
@ -450,6 +466,8 @@ contains
call psb_bcast(ictxt,itrace) call psb_bcast(ictxt,itrace)
call psb_bcast(ictxt,irst) call psb_bcast(ictxt,irst)
call psb_bcast(ictxt,eps) 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%descr) ! verbose description of the prec
call psb_bcast(ictxt,prectype%prec) ! overall prectype call psb_bcast(ictxt,prectype%prec) ! overall prectype
call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels 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%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin
call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation 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_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%mltype) ! additive or multiplicative 2nd level prec
call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing
call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps

53
tests/pdegen/mld_d_pde3d.f90
Unescape Escape View File

@ -68,49 +68,49 @@ contains
! functions parametrizing the differential equation ! functions parametrizing the differential equation
! !
function b1(x,y,z) 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_) :: b1
real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_), intent(in) :: x,y,z
b1=0.d0/sqrt(3.d0) b1=dzero/sqrt((3*done))
end function b1 end function b1
function b2(x,y,z) 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_) :: b2
real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_), intent(in) :: x,y,z
b2=0.d0/sqrt(3.d0) b2=dzero/sqrt((3*done))
end function b2 end function b2
function b3(x,y,z) 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_) :: b3
real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_), intent(in) :: x,y,z
b3=0.d0/sqrt(3.d0) b3=dzero/sqrt((3*done))
end function b3 end function b3
function c(x,y,z) 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_) :: c
real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_), intent(in) :: x,y,z
c=0.d0 c=dzero
end function c end function c
function a1(x,y,z) 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_) :: a1
real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_), intent(in) :: x,y,z
a1=1.d0!/80 a1=done!/80
end function a1 end function a1
function a2(x,y,z) 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_) :: a2
real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_), intent(in) :: x,y,z
a2=1.d0!/80 a2=done!/80
end function a2 end function a2
function a3(x,y,z) 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_) :: a3
real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_), intent(in) :: x,y,z
a3=1.d0!/80 a3=done!/80
end function a3 end function a3
function g(x,y,z) 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_) :: g
real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_), intent(in) :: x,y,z
g = dzero g = dzero
@ -171,6 +171,7 @@ program mld_d_pde3d
character(len=16) :: aggrkind ! smoothed/raw aggregatin character(len=16) :: aggrkind ! smoothed/raw aggregatin
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: aggr_ord ! Ordering for 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) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer(psb_ipk_) :: csize ! aggregation size at which to stop. integer(psb_ipk_) :: csize ! aggregation size at which to stop.
@ -186,6 +187,8 @@ program mld_d_pde3d
type(precdata) :: prectype type(precdata) :: prectype
type(psb_d_coo_sparse_mat) :: acoo type(psb_d_coo_sparse_mat) :: acoo
! other variables ! other variables
logical :: dump_prec
character(len=40) :: dump_prefix
integer(psb_ipk_) :: info, i integer(psb_ipk_) :: info, i
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
@ -214,7 +217,8 @@ program mld_d_pde3d
! !
! get parameters ! 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 ! 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_kind', prectype%aggrkind,info)
call mld_precset(prec,'aggr_alg', prectype%aggr_alg,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_ord', prectype%aggr_ord,info)
call mld_precset(prec,'aggr_filter', prectype%aggr_filter, info)
call psb_barrier(ictxt) call psb_barrier(ictxt)
t1 = psb_wtime() t1 = psb_wtime()
@ -380,6 +385,10 @@ program mld_d_pde3d
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize
end if 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 ! cleanup storage and exit
! !
@ -404,13 +413,17 @@ contains
! !
! get iteration parameters from standard input ! 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 integer(psb_ipk_) :: ictxt
type(precdata) :: prectype type(precdata) :: prectype
character(len=*) :: kmethd, afmt character(len=*) :: kmethd, afmt
integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst
integer(psb_ipk_) :: np, iam, info integer(psb_ipk_) :: np, iam, info
real(psb_dpk_) :: eps real(psb_dpk_) :: eps
logical :: dump_prec
character(len=*) :: dump_prefix
character(len=20) :: buffer character(len=20) :: buffer
call psb_info(ictxt, iam, np) call psb_info(ictxt, iam, np)
@ -424,6 +437,8 @@ contains
call read_data(itrace,psb_inp_unit) call read_data(itrace,psb_inp_unit)
call read_data(irst,psb_inp_unit) call read_data(irst,psb_inp_unit)
call read_data(eps,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%descr,psb_inp_unit) ! verbose description of the prec
call read_data(prectype%prec,psb_inp_unit) ! overall prectype call read_data(prectype%prec,psb_inp_unit) ! overall prectype
call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels 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%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_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_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%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%smthpos,psb_inp_unit) ! side: pre, post, both smoothing
call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps
@ -462,6 +478,8 @@ contains
call psb_bcast(ictxt,itrace) call psb_bcast(ictxt,itrace)
call psb_bcast(ictxt,irst) call psb_bcast(ictxt,irst)
call psb_bcast(ictxt,eps) 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%descr) ! verbose description of the prec
call psb_bcast(ictxt,prectype%prec) ! overall prectype call psb_bcast(ictxt,prectype%prec) ! overall prectype
call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels 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%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin
call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation 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_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%mltype) ! additive or multiplicative 2nd level prec
call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing
call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps

61
tests/pdegen/mld_s_pde2d.f90
Unescape Escape View File

@ -1,8 +1,8 @@
!!!$ !!!$
!!$ !!$
!!$ MLD2P4 version 2.0 !!$ MLD2P4 version 2.1
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package !!$ 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 !!$ (C) Copyright 2008, 2010, 2012, 2015
!!$ !!$
@ -69,43 +69,43 @@ contains
! functions parametrizing the differential equation ! functions parametrizing the differential equation
! !
function b1(x,y) 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_) :: b1
real(psb_spk_), intent(in) :: x,y real(psb_spk_), intent(in) :: x,y
b1=0.d0/sqrt(2.d0) b1=szero/sqrt((2*sone))
end function b1 end function b1
function b2(x,y) 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_) :: b2
real(psb_spk_), intent(in) :: x,y real(psb_spk_), intent(in) :: x,y
b2=0.d0/sqrt(2.d0) b2=szero/sqrt((2*sone))
end function b2 end function b2
function c(x,y) 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_) :: c
real(psb_spk_), intent(in) :: x,y real(psb_spk_), intent(in) :: x,y
c=0.d0 c=szero
end function c end function c
function a1(x,y) 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_) :: a1
real(psb_spk_), intent(in) :: x,y real(psb_spk_), intent(in) :: x,y
a1=1.d0!/80 a1=sone!/80
end function a1 end function a1
function a2(x,y) 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_) :: a2
real(psb_spk_), intent(in) :: x,y real(psb_spk_), intent(in) :: x,y
a2=1.d0!/80 a2=sone!/80
end function a2 end function a2
function g(x,y) 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_) :: g
real(psb_spk_), intent(in) :: x,y real(psb_spk_), intent(in) :: x,y
g = dzero g = szero
if (x == done) then if (x == sone) then
g = done g = sone
else if (x == dzero) then else if (x == szero) then
g = exp(-y**2) g = exp(-y**2)
end if end if
end function g end function g
@ -160,6 +160,7 @@ program mld_s_pde2d
character(len=16) :: aggrkind ! smoothed/raw aggregatin character(len=16) :: aggrkind ! smoothed/raw aggregatin
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: aggr_ord ! Ordering for 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) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer(psb_ipk_) :: csize ! aggregation size at which to stop. integer(psb_ipk_) :: csize ! aggregation size at which to stop.
@ -175,6 +176,8 @@ program mld_s_pde2d
type(precdata) :: prectype type(precdata) :: prectype
type(psb_s_coo_sparse_mat) :: acoo type(psb_s_coo_sparse_mat) :: acoo
! other variables ! other variables
logical :: dump_prec
character(len=40) :: dump_prefix
integer(psb_ipk_) :: info, i integer(psb_ipk_) :: info, i
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
@ -203,7 +206,8 @@ program mld_s_pde2d
! !
! get parameters ! 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 ! allocate and fill in the coefficient matrix, rhs and initial guess
@ -241,11 +245,12 @@ program mld_s_pde2d
if (prectype%mnaggratio>0)& if (prectype%mnaggratio>0)&
& call mld_precset(prec,'min_aggr_ratio', prectype%mnaggratio, info) & call mld_precset(prec,'min_aggr_ratio', prectype%mnaggratio, info)
end if end if
if (prectype%athres >= dzero) & if (prectype%athres >= szero) &
& call mld_precset(prec,'aggr_thresh', prectype%athres, info) & call mld_precset(prec,'aggr_thresh', prectype%athres, info)
call mld_precset(prec,'aggr_kind', prectype%aggrkind,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_alg', prectype%aggr_alg,info)
call mld_precset(prec,'aggr_ord', prectype%aggr_ord,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) call psb_barrier(ictxt)
t1 = psb_wtime() t1 = psb_wtime()
@ -300,7 +305,7 @@ program mld_s_pde2d
call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info) call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info)
call mld_precset(prec,'sub_iluthrs', prectype%thr1, info) call mld_precset(prec,'sub_iluthrs', prectype%thr1, info)
call psb_barrier(ictxt) call psb_barrier(ictxt)
thier = dzero thier = szero
t1 = psb_wtime() t1 = psb_wtime()
call mld_precbld(a,desc_a,prec,info) call mld_precbld(a,desc_a,prec,info)
if(info /= psb_success_) then if(info /= psb_success_) then
@ -368,6 +373,10 @@ program mld_s_pde2d
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize
end if 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 ! cleanup storage and exit
! !
@ -392,13 +401,17 @@ contains
! !
! get iteration parameters from standard input ! 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 integer(psb_ipk_) :: ictxt
type(precdata) :: prectype type(precdata) :: prectype
character(len=*) :: kmethd, afmt character(len=*) :: kmethd, afmt
integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst
integer(psb_ipk_) :: np, iam, info integer(psb_ipk_) :: np, iam, info
real(psb_spk_) :: eps real(psb_spk_) :: eps
logical :: dump_prec
character(len=*) :: dump_prefix
character(len=20) :: buffer character(len=20) :: buffer
call psb_info(ictxt, iam, np) call psb_info(ictxt, iam, np)
@ -412,6 +425,8 @@ contains
call read_data(itrace,psb_inp_unit) call read_data(itrace,psb_inp_unit)
call read_data(irst,psb_inp_unit) call read_data(irst,psb_inp_unit)
call read_data(eps,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%descr,psb_inp_unit) ! verbose description of the prec
call read_data(prectype%prec,psb_inp_unit) ! overall prectype call read_data(prectype%prec,psb_inp_unit) ! overall prectype
call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels 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%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_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_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%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%smthpos,psb_inp_unit) ! side: pre, post, both smoothing
call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps
@ -450,6 +466,8 @@ contains
call psb_bcast(ictxt,itrace) call psb_bcast(ictxt,itrace)
call psb_bcast(ictxt,irst) call psb_bcast(ictxt,irst)
call psb_bcast(ictxt,eps) 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%descr) ! verbose description of the prec
call psb_bcast(ictxt,prectype%prec) ! overall prectype call psb_bcast(ictxt,prectype%prec) ! overall prectype
call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels 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%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin
call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation 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_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%mltype) ! additive or multiplicative 2nd level prec
call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing
call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps

65
tests/pdegen/mld_s_pde3d.f90
Unescape Escape View File

@ -68,55 +68,55 @@ contains
! functions parametrizing the differential equation ! functions parametrizing the differential equation
! !
function b1(x,y,z) 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_) :: b1
real(psb_spk_), intent(in) :: x,y,z real(psb_spk_), intent(in) :: x,y,z
b1=0.d0/sqrt(3.d0) b1=szero/sqrt((3*sone))
end function b1 end function b1
function b2(x,y,z) 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_) :: b2
real(psb_spk_), intent(in) :: x,y,z real(psb_spk_), intent(in) :: x,y,z
b2=0.d0/sqrt(3.d0) b2=szero/sqrt((3*sone))
end function b2 end function b2
function b3(x,y,z) 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_) :: b3
real(psb_spk_), intent(in) :: x,y,z real(psb_spk_), intent(in) :: x,y,z
b3=0.d0/sqrt(3.d0) b3=szero/sqrt((3*sone))
end function b3 end function b3
function c(x,y,z) 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_) :: c
real(psb_spk_), intent(in) :: x,y,z real(psb_spk_), intent(in) :: x,y,z
c=0.d0 c=szero
end function c end function c
function a1(x,y,z) 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_) :: a1
real(psb_spk_), intent(in) :: x,y,z real(psb_spk_), intent(in) :: x,y,z
a1=1.d0!/80 a1=sone!/80
end function a1 end function a1
function a2(x,y,z) 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_) :: a2
real(psb_spk_), intent(in) :: x,y,z real(psb_spk_), intent(in) :: x,y,z
a2=1.d0!/80 a2=sone!/80
end function a2 end function a2
function a3(x,y,z) 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_) :: a3
real(psb_spk_), intent(in) :: x,y,z real(psb_spk_), intent(in) :: x,y,z
a3=1.d0!/80 a3=sone!/80
end function a3 end function a3
function g(x,y,z) 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_) :: g
real(psb_spk_), intent(in) :: x,y,z real(psb_spk_), intent(in) :: x,y,z
g = dzero g = szero
if (x == done) then if (x == sone) then
g = done g = sone
else if (x == dzero) then else if (x == szero) then
g = exp(y**2-z**2) g = exp(y**2-z**2)
end if end if
end function g end function g
@ -171,6 +171,7 @@ program mld_s_pde3d
character(len=16) :: aggrkind ! smoothed/raw aggregatin character(len=16) :: aggrkind ! smoothed/raw aggregatin
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: aggr_ord ! Ordering for 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) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer(psb_ipk_) :: csize ! aggregation size at which to stop. integer(psb_ipk_) :: csize ! aggregation size at which to stop.
@ -186,6 +187,8 @@ program mld_s_pde3d
type(precdata) :: prectype type(precdata) :: prectype
type(psb_s_coo_sparse_mat) :: acoo type(psb_s_coo_sparse_mat) :: acoo
! other variables ! other variables
logical :: dump_prec
character(len=40) :: dump_prefix
integer(psb_ipk_) :: info, i integer(psb_ipk_) :: info, i
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
@ -214,7 +217,8 @@ program mld_s_pde3d
! !
! get parameters ! 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 ! allocate and fill in the coefficient matrix, rhs and initial guess
@ -253,11 +257,12 @@ program mld_s_pde3d
if (prectype%mnaggratio>0)& if (prectype%mnaggratio>0)&
& call mld_precset(prec,'min_aggr_ratio', prectype%mnaggratio, info) & call mld_precset(prec,'min_aggr_ratio', prectype%mnaggratio, info)
end if end if
if (prectype%athres >= dzero) & if (prectype%athres >= szero) &
& call mld_precset(prec,'aggr_thresh', prectype%athres, info) & call mld_precset(prec,'aggr_thresh', prectype%athres, info)
call mld_precset(prec,'aggr_kind', prectype%aggrkind,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_alg', prectype%aggr_alg,info)
call mld_precset(prec,'aggr_ord', prectype%aggr_ord,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) call psb_barrier(ictxt)
t1 = psb_wtime() t1 = psb_wtime()
@ -312,7 +317,7 @@ program mld_s_pde3d
call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info) call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info)
call mld_precset(prec,'sub_iluthrs', prectype%thr1, info) call mld_precset(prec,'sub_iluthrs', prectype%thr1, info)
call psb_barrier(ictxt) call psb_barrier(ictxt)
thier = dzero thier = szero
t1 = psb_wtime() t1 = psb_wtime()
call mld_precbld(a,desc_a,prec,info) call mld_precbld(a,desc_a,prec,info)
if(info /= psb_success_) then if(info /= psb_success_) then
@ -380,6 +385,10 @@ program mld_s_pde3d
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize
end if 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 ! cleanup storage and exit
! !
@ -404,13 +413,17 @@ contains
! !
! get iteration parameters from standard input ! 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 integer(psb_ipk_) :: ictxt
type(precdata) :: prectype type(precdata) :: prectype
character(len=*) :: kmethd, afmt character(len=*) :: kmethd, afmt
integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst
integer(psb_ipk_) :: np, iam, info integer(psb_ipk_) :: np, iam, info
real(psb_spk_) :: eps real(psb_spk_) :: eps
logical :: dump_prec
character(len=*) :: dump_prefix
character(len=20) :: buffer character(len=20) :: buffer
call psb_info(ictxt, iam, np) call psb_info(ictxt, iam, np)
@ -424,6 +437,8 @@ contains
call read_data(itrace,psb_inp_unit) call read_data(itrace,psb_inp_unit)
call read_data(irst,psb_inp_unit) call read_data(irst,psb_inp_unit)
call read_data(eps,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%descr,psb_inp_unit) ! verbose description of the prec
call read_data(prectype%prec,psb_inp_unit) ! overall prectype call read_data(prectype%prec,psb_inp_unit) ! overall prectype
call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels 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%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_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_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%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%smthpos,psb_inp_unit) ! side: pre, post, both smoothing
call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps
@ -462,6 +478,8 @@ contains
call psb_bcast(ictxt,itrace) call psb_bcast(ictxt,itrace)
call psb_bcast(ictxt,irst) call psb_bcast(ictxt,irst)
call psb_bcast(ictxt,eps) 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%descr) ! verbose description of the prec
call psb_bcast(ictxt,prectype%prec) ! overall prectype call psb_bcast(ictxt,prectype%prec) ! overall prectype
call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels 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%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin
call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation 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_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%mltype) ! additive or multiplicative 2nd level prec
call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing
call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps

23
tests/pdegen/runs/ppde.inp
Unescape Escape View File

@ -1,35 +1,38 @@
BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG
CSR ! Storage format CSR COO JAD CSR ! Storage format CSR COO JAD
0100 ! IDIM; domain size is idim**3 0080 ! IDIM; domain size is idim**3
2 ! ISTOPC 2 ! ISTOPC
2000 ! ITMAX 2000 ! ITMAX
10 ! ITRACE 10 ! ITRACE
30 ! IRST (restart for RGMRES and BiCGSTABL) 30 ! IRST (restart for RGMRES and BiCGSTABL)
1.d-6 ! EPS 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-MUL-RAS-ILU ! Descriptive name for preconditioner (up to 40 chars)
ML ! Preconditioner NONE JACOBI BJAC AS ML ML ! Preconditioner NONE JACOBI BJAC AS ML
-1 ! If ML: Prescribed number of levels; if <0, ignore it and use coarse size. -4 ! 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 -8000 ! If ML: Target coarse size. If <0, then use library default
-1.5d0 ! If ML: Minimum aggregation ratio; if <0 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 -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 -20 ! If ML: Maximum acceptable number of levels; if <0 use library default
SMOOTHED ! Type of aggregation: SMOOTHED, NONSMOOTHED, MINENERGY SMOOTHED ! Type of aggregation: SMOOTHED, UNSMOOTHED, MINENERGY
SYMDEC ! Type of aggregation: DEC SYMDEC DEC ! Type of aggregation: DEC SYMDEC
NATURAL ! Ordering of aggregation: NATURAL DEGREE NATURAL ! Ordering of aggregation: NATURAL DEGREE
FILTER ! Filtering aggregation: FILTER NO_FILTER
MULT ! Type of multilevel correction: ADD MULT KCYCLE VCYCLE WCYCLE KCYCLESYM MULT ! Type of multilevel correction: ADD MULT KCYCLE VCYCLE WCYCLE KCYCLESYM
TWOSIDE ! Side of correction: PRE POST TWOSIDE (ignored for ADD) 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 BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML
0 ! Number of overlap layers for AS preconditioner (at finest level) 0 ! Number of overlap layers for AS preconditioner (at finest level)
HALO ! AS Restriction operator NONE HALO HALO ! AS Restriction operator NONE HALO
NONE ! AS Prolongation operator NONE SUM AVG NONE ! AS Prolongation operator NONE SUM AVG
GS ! Subdomain solver DSCALE ILU MILU ILUT FWGS BWGS MUMPS UMF SLU ILU ! Subdomain solver DSCALE ILU MILU ILUT FWGS BWGS MUMPS UMF SLU
4 ! Solver sweeps for GS 1 ! Solver sweeps for GS
0 ! Level-set N for ILU(N), and P for ILUT 0 ! Level-set N for ILU(N), and P for ILUT
1.d-4 ! Threshold T for ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P)
DIST ! Coarse level: matrix distribution DIST REPL DIST ! Coarse level: matrix distribution DIST REPL
BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST MUMPS 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 ! Coarse level: Level-set N for ILU(N)
1.d-4 ! Coarse level: Threshold T for ILU(T,P) 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

Write Preview
Loading…
Cancel
Save