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 8 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
history.
2016/10/03: Merged changes to hierearchy building.
2016/08/20: Reimplemented decoupled aggregation
2016/07/20: Refactored application of multilevel. Defined V,W and
K-cycles.
2016/05/18: Reworked internals of PRECSET. Defined Forward-Backward
Gauss-Seidel solver. Now available separate PRE and POST smoother
objects.

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
DINNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_d_bld_mlhier_aggsize.o mld_d_bld_mlhier_array.o \
mld_d_ml_prec_bld.o mld_d_hierarchy_bld.o \
DINNEROBJS= mld_dmlprec_bld.o \
mld_d_smoothers_bld.o mld_d_hierarchy_bld.o \
mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \
mld_d_dec_map_bld.o mld_dmlprec_aply.o mld_daggrmat_asb.o \
$(DMPFOBJS) mld_d_extprol_bld.o
$(DMPFOBJS) mld_d_extprol_bld.o mld_d_lev_aggrmap_bld.o mld_d_lev_aggrmat_asb.o
SINNEROBJS= mld_scoarse_bld.o mld_smlprec_bld.o mld_s_bld_mlhier_aggsize.o mld_s_bld_mlhier_array.o \
mld_s_ml_prec_bld.o mld_s_hierarchy_bld.o \
SINNEROBJS= mld_smlprec_bld.o \
mld_s_smoothers_bld.o mld_s_hierarchy_bld.o \
mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o mld_saggrmap_bld.o \
mld_s_dec_map_bld.o mld_smlprec_aply.o mld_saggrmat_asb.o \
$(SMPFOBJS) mld_s_extprol_bld.o
$(SMPFOBJS) mld_s_extprol_bld.o mld_s_lev_aggrmap_bld.o mld_s_lev_aggrmat_asb.o
ZINNEROBJS= mld_zcoarse_bld.o mld_zmlprec_bld.o mld_z_bld_mlhier_aggsize.o mld_z_bld_mlhier_array.o \
mld_z_ml_prec_bld.o mld_z_hierarchy_bld.o \
ZINNEROBJS= mld_zmlprec_bld.o \
mld_z_smoothers_bld.o mld_z_hierarchy_bld.o \
mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \
mld_z_dec_map_bld.o mld_zmlprec_aply.o mld_zaggrmat_asb.o \
$(ZMPFOBJS) mld_z_extprol_bld.o
$(ZMPFOBJS) mld_z_extprol_bld.o mld_z_lev_aggrmap_bld.o mld_z_lev_aggrmat_asb.o
CINNEROBJS= mld_ccoarse_bld.o mld_cmlprec_bld.o mld_c_bld_mlhier_aggsize.o mld_c_bld_mlhier_array.o \
mld_c_ml_prec_bld.o mld_c_hierarchy_bld.o \
CINNEROBJS= mld_cmlprec_bld.o \
mld_c_smoothers_bld.o mld_c_hierarchy_bld.o \
mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \
mld_c_dec_map_bld.o mld_cmlprec_aply.o mld_caggrmat_asb.o \
$(CMPFOBJS) mld_c_extprol_bld.o
$(CMPFOBJS) mld_c_extprol_bld.o mld_c_lev_aggrmap_bld.o mld_c_lev_aggrmat_asb.o
INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS)

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
type(psb_c_csr_sparse_mat) :: acsr
real(psb_spk_) :: cpling, tcl
logical :: recovery, disjoint
logical :: disjoint
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
@ -138,16 +138,14 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end if
end if
enddo
if (ip < 1) then
write(0,*) "Should at least contain the node itself ! "
cycle step1
end if
!
! If the whole strongly coupled neighborhood of I is
! as yet unconnected, turn it into the next aggregate
! as yet unconnected, turn it into the next aggregate.
! Same if ip==0 (in which case, neighborhood only
! contains I even if it does not look from matrix)
!
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1))
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
icnt = icnt + 1
naggr = naggr + 1
@ -207,7 +205,7 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
step3: do ii=1,nr
i = idxs(ii)
if (ilaggr(i) < 0) then
if (ilaggr(i) < 0) then
call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
@ -218,7 +216,7 @@ subroutine mld_c_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
! Find its strongly connected neighbourhood not
! already aggregated, and make it into a new aggregate.
!
cpling = szero
cpling = dzero
ip = 0
do k=1, nz
j = icol(k)

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

@ -62,19 +62,8 @@
! of the preconditioner to be built.
! info - integer, output.
! Error code.
!
! amold - class(psb_c_base_sparse_mat), input, optional
! Mold for the inner format of matrices contained in the
! preconditioner
!
!
! vmold - class(psb_c_base_vect_type), input, optional
! Mold for the inner format of vectors contained in the
! preconditioner
!
!
!
subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
subroutine mld_c_hierarchy_bld(a,desc_a,p,info)
use psb_base_mod
use mld_c_inner_mod
@ -87,16 +76,17 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
type(psb_desc_type), intent(inout), target :: desc_a
type(mld_cprec_type),intent(inout),target :: p
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs
real(psb_spk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_spk_) :: mnaggratio, sizeratio
class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2
type(mld_sml_parms) :: baseparms, medparms, coarseparms
integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:)
type(psb_cspmat_type) :: op_prol
type(mld_c_onelev_type), allocatable :: tprecv(:)
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
@ -191,10 +181,22 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
goto 9999
endif
!
! The strategy:
! 1. The maximum number of levels should be already encoded in the
! size of the array;
! 2. If the user did not specify anything, then a default coarse size
! is generated, and the number of levels is set to the maximum;
! 3. If the number of levels has been specified, make sure it's capped
! at the maximum;
! 4. If the size of the array is different from target number of levels,
! reallocate;
! 5. Build the matrix hierarchy, stopping early if either the target
! coarse size is hit, or the gain falls below the min_aggr_ratio
! threshold.
!
if (nplevs <= 0) then
!
! This should become the default strategy, we specify a target aggregation size.
!
if (casize <=0) then
!
! Default to the cubic root of the size at base level.
@ -204,15 +206,194 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
casize = max(casize,ione)
casize = casize*40_psb_ipk_
end if
call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info)
else
nplevs = mxplevs
end if
nplevs = max(itwo,min(nplevs,mxplevs))
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
call save_smoothers(p%precv(iszv),coarse_sm,coarse_sm2,info)
if (info == 0) call save_smoothers(p%precv(2),med_sm,med_sm2,info)
if (info == 0) call save_smoothers(p%precv(1),base_sm,base_sm2,info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! First set desired number of levels
!
if (iszv /= nplevs) then
allocate(tprecv(nplevs),stat=info)
! First all existing levels
if (info == 0) tprecv(1)%parms = baseparms
if (info == 0) call restore_smoothers(tprecv(1),p%precv(1)%sm,p%precv(1)%sm2a,info)
do i=2, min(iszv,nplevs) - 1
if (info == 0) tprecv(i)%parms = medparms
if (info == 0) call restore_smoothers(tprecv(i),p%precv(i)%sm,p%precv(i)%sm2a,info)
end do
! Further intermediates, if any
do i=iszv-1, nplevs - 1
if (info == 0) tprecv(i)%parms = medparms
if (info == 0) call restore_smoothers(tprecv(i),med_sm,med_sm2,info)
end do
! Then coarse
if (info == 0) tprecv(nplevs)%parms = coarseparms
if (info == 0) call restore_smoothers(tprecv(nplevs),coarse_sm,coarse_sm2,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,iszv
call p%precv(i)%free(info)
end do
call move_alloc(tprecv,p%precv)
iszv = size(p%precv)
end if
!
! Finest level first; remember to fix base_a and base_desc
!
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
newsz = 0
array_build_loop: do i=2, iszv
!
! Check on the iprcparm contents: they should be the same
! on all processes.
!
call psb_bcast(ictxt,p%precv(i)%parms)
!
! Sanity checks on the parameters
!
if (i<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))
call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info)
end if
! Check for early termination of aggregation loop.
!
iaggsize = sum(nlaggr)
if (iaggsize <= casize) then
newsz = i
end if
if (i>2) then
sizeratio = iaggsize
sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio
if (sizeratio < mnaggratio) then
if (sizeratio > 1) then
newsz = i
else
!
! We are not gaining
!
newsz = i-1
end if
end if
if (all(nlaggr == p%precv(i-1)%map%naggr)) then
newsz=i-1
if (me == 0) then
write(debug_unit,*) trim(name),&
&': Warning: aggregates from level ',&
& newsz
write(debug_unit,*) trim(name),&
&': to level ',&
& iszv,' coincide.'
write(debug_unit,*) trim(name),&
&': Number of levels actually used :',newsz
write(debug_unit,*)
end if
end if
end if
call psb_bcast(ictxt,newsz)
if (newsz > 0) then
if (info == 0) p%precv(newsz)%parms = coarseparms
if (info == 0) call restore_smoothers(p%precv(newsz),coarse_sm,coarse_sm2,info)
if (info == psb_success_) call mld_lev_mat_asb(p%precv(newsz),&
& p%precv(newsz-1)%base_a,p%precv(newsz-1)%base_desc,&
& ilaggr,nlaggr,op_prol,info)
exit array_build_loop
else
if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),&
& p%precv(i-1)%base_a,p%precv(i-1)%base_desc,&
& ilaggr,nlaggr,op_prol,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Map build')
goto 9999
endif
end do array_build_loop
if (newsz > 0) then
!
! We exited early from the build loop, need to fix
! the size.
!
allocate(tprecv(newsz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,newsz
call p%precv(i)%move_alloc(tprecv(i),info)
end do
do i=newsz+1, iszv
call p%precv(i)%free(info)
end do
call move_alloc(tprecv,p%precv)
! Ignore errors from transfer
info = psb_success_
!
! Restart
iszv = newsz
! Fix the pointers, but the level 1 should
! be already OK
do i=2, iszv
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' )
@ -220,7 +401,7 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
endif
iszv = size(p%precv)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
@ -232,4 +413,58 @@ subroutine mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
return
contains
subroutine save_smoothers(level,save1, save2,info)
type(mld_c_onelev_type), intent(in) :: level
class(mld_c_base_smoother_type), allocatable , intent(inout) :: save1, save2
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(save1)) then
call save1%free(info)
if (info == 0) deallocate(save1,stat=info)
if (info /= 0) return
end if
if (allocated(save2)) then
call save2%free(info)
if (info == 0) deallocate(save2,stat=info)
if (info /= 0) return
end if
allocate(save1, source=level%sm,stat=info)
if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info)
return
end subroutine save_smoothers
subroutine restore_smoothers(level,save1, save2,info)
type(mld_c_onelev_type), intent(inout), target :: level
class(mld_c_base_smoother_type), allocatable, intent(in) :: save1, save2
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(level%sm)) then
if (info == 0) call level%sm%free(info)
if (info == 0) deallocate(level%sm,stat=info)
end if
if (allocated(save1)) then
if (info == 0) allocate(level%sm,source=save1,stat=info)
end if
if (info /= 0) return
if (allocated(level%sm2a)) then
if (info == 0) call level%sm2a%free(info)
if (info == 0) deallocate(level%sm2a,stat=info)
end if
if (allocated(save2)) then
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
if (info == 0) level%sm2 => level%sm2a
else
if (allocated(level%sm)) level%sm2 => level%sm
end if
return
end subroutine restore_smoothers
end subroutine mld_c_hierarchy_bld

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.
!!$
!!$
! File: mld_c_ml_prec_bld.f90
! File: mld_c_smoothers_bld.f90
!
! Subroutine: mld_c_ml_prec_bld
! Subroutine: mld_c_smoothers_bld
! Version: complex
!
! This routine builds the preconditioner according to the requirements made by
@ -74,11 +74,11 @@
!
!
!
subroutine mld_c_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
subroutine mld_c_smoothers_bld(a,desc_a,p,info,amold,vmold,imold)
use psb_base_mod
use mld_c_inner_mod
use mld_c_prec_mod, mld_protect_name => mld_c_ml_prec_bld
use mld_c_prec_mod, mld_protect_name => mld_c_smoothers_bld
Implicit None
@ -109,7 +109,7 @@ subroutine mld_c_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
name = 'mld_c_ml_prec_bld'
name = 'mld_c_smoothers_bld'
info = psb_success_
int_err(1) = 0
ictxt = desc_a%get_context()
@ -191,4 +191,4 @@ subroutine mld_c_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
return
end subroutine mld_c_ml_prec_bld
end subroutine mld_c_smoothers_bld

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

@ -79,7 +79,7 @@
! info - integer, output.
! Error code.
!
subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod
use mld_c_inner_mod, mld_protect_name => mld_caggrmap_bld
@ -93,13 +93,14 @@ subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_cspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_), allocatable :: ils(:), neigh(:)
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m,naggrm1, naggrp1, ntaggr
type(psb_cspmat_type) :: atmp, atrans
logical :: recovery
type(psb_c_coo_sparse_mat) :: tmpcoo
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
@ -151,6 +152,28 @@ subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
goto 9999
end if
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = cone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_from(tmpcoo)
call psb_erractionrestore(err_act)
return

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

@ -98,7 +98,7 @@
! info - integer, output.
! Error code.
!
subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod
use mld_c_inner_mod, mld_protect_name => mld_caggrmat_asb
@ -109,11 +109,11 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_c_onelev_type), intent(inout), target :: p
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(inout) :: ac, op_prol,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
type(psb_cspmat_type) :: ac, op_prol,op_restr
type(psb_c_coo_sparse_mat) :: acoo, bcoo
type(psb_c_csr_sparse_mat) :: acsr1
integer(psb_ipk_) :: nzl,ntaggr, err_act
@ -133,26 +133,26 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_info(ictxt, me, np)
select case (p%parms%aggr_kind)
select case (parms%aggr_kind)
case (mld_no_smooth_)
call mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_smooth_prol_)
call mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_biz_prol_)
call mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_min_energy_)
call mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case default
info = psb_err_internal_error_
@ -165,116 +165,6 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
ntaggr = sum(nlaggr)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
call ac%mv_to(bcoo)
if (p%parms%clean_zeros) call bcoo%clean_zeros(info)
nzl = bcoo%get_nzeros()
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
goto 9999
end if
if (np>1) then
call op_prol%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call op_prol%mv_from(acsr1)
endif
call op_prol%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
call op_restr%mv_to(acoo)
nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call op_restr%mv_from(acoo)
if (info == psb_success_) call op_restr%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Converting op_restr to local')
goto 9999
end if
end if
!
! Clip to local rows.
!
call op_restr%set_nrows(p%desc_ac%get_local_rows())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if ((info == psb_success_).and.p%parms%clean_zeros) call ac%clean_zeros(info)
if (info == psb_success_) &
& call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! op_restr => PR^T i.e. restriction operator
! op_prol => PR i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,op_restr,op_prol,ilaggr,nlaggr)
if (info == psb_success_) call op_prol%free()
if (info == psb_success_) call op_restr%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act)
return

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_cspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -128,19 +129,8 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
@ -157,17 +147,10 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol)
do i=1,nrow
tmpcoo%val(i) = cone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(nrow)
call tmpcoo%set_dupl(psb_dupl_add_)
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -197,19 +180,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
end if

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_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -167,14 +168,6 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
@ -209,20 +202,10 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = cone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_asb()
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1')
if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
@ -276,7 +259,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call am3%mv_to(acsr3)
! Compute omega_int
ommx = cmplx(szero,szero)
ommx = czero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
@ -316,18 +299,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
!
! Build the smoothed prolongator using the filtered matrix
@ -454,7 +426,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int
ommx = cmplx(szero,szero)
ommx = czero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_cspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -124,34 +125,12 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
ntaggr = sum(nlaggr)
naggrm1=sum(nlaggr(1:me))
do i=1, nrow
ilaggr(i) = ilaggr(i) + naggrm1
end do
call psb_halo(ilaggr,desc_a,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
call acoo%allocate(ncol,ntaggr,ncol)
do i=1,nrow
acoo%val(i) = cone
acoo%ia(i) = i
acoo%ja(i) = ilaggr(i)
end do
call acoo%set_dupl(psb_dupl_add_)
call acoo%set_nzeros(nrow)
call acoo%set_asb()
call acoo%fix(info)
call op_prol%mv_from(acoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call op_prol%transp(op_restr)
if (info /= psb_success_) goto 9999
call op_prol%transp(op_restr)
call a%cp_to(ac_coo)
nzt = ac_coo%get_nzeros()

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_cspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -147,14 +148,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
!
! naggr: number of local aggregates
! nrow: local rows.
!
@ -172,17 +166,10 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = cone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -212,19 +199,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
end if

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_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE')
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)

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),&
& 'Entering '
call mld_c_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
call mld_c_hierarchy_bld(a,desc_a,p,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
@ -129,7 +129,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
iszv = p%get_nlevs()
call mld_c_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
call mld_c_smoothers_bld(a,desc_a,p,info,amold,vmold,imold)
if (info /= psb_success_) then
info=psb_err_internal_error_

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_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call p%precv(ilev_)%set(mld_aggr_scale_,scale,info)
call p%precv(ilev_)%set(mld_aggr_filter_,mld_no_filter_mat_,info)
call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info)
end do
case default

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
type(psb_d_csr_sparse_mat) :: acsr
real(psb_dpk_) :: cpling, tcl
logical :: recovery, disjoint
logical :: disjoint
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
@ -138,16 +138,14 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end if
end if
enddo
if (ip < 1) then
write(0,*) "Should at least contain the node itself ! "
cycle step1
end if
!
! If the whole strongly coupled neighborhood of I is
! as yet unconnected, turn it into the next aggregate
! as yet unconnected, turn it into the next aggregate.
! Same if ip==0 (in which case, neighborhood only
! contains I even if it does not look from matrix)
!
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1))
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
icnt = icnt + 1
naggr = naggr + 1
@ -207,7 +205,7 @@ subroutine mld_d_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
step3: do ii=1,nr
i = idxs(ii)
if (ilaggr(i) < 0) then
if (ilaggr(i) < 0) then
call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_

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

@ -62,19 +62,8 @@
! of the preconditioner to be built.
! info - integer, output.
! Error code.
!
! amold - class(psb_d_base_sparse_mat), input, optional
! Mold for the inner format of matrices contained in the
! preconditioner
!
!
! vmold - class(psb_d_base_vect_type), input, optional
! Mold for the inner format of vectors contained in the
! preconditioner
!
!
!
subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
subroutine mld_d_hierarchy_bld(a,desc_a,p,info)
use psb_base_mod
use mld_d_inner_mod
@ -87,16 +76,17 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
type(psb_desc_type), intent(inout), target :: desc_a
type(mld_dprec_type),intent(inout),target :: p
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs
real(psb_dpk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_dpk_) :: mnaggratio, sizeratio
class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2
type(mld_dml_parms) :: baseparms, medparms, coarseparms
integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:)
type(psb_dspmat_type) :: op_prol
type(mld_d_onelev_type), allocatable :: tprecv(:)
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
@ -191,10 +181,22 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
goto 9999
endif
!
! The strategy:
! 1. The maximum number of levels should be already encoded in the
! size of the array;
! 2. If the user did not specify anything, then a default coarse size
! is generated, and the number of levels is set to the maximum;
! 3. If the number of levels has been specified, make sure it's capped
! at the maximum;
! 4. If the size of the array is different from target number of levels,
! reallocate;
! 5. Build the matrix hierarchy, stopping early if either the target
! coarse size is hit, or the gain falls below the min_aggr_ratio
! threshold.
!
if (nplevs <= 0) then
!
! This should become the default strategy, we specify a target aggregation size.
!
if (casize <=0) then
!
! Default to the cubic root of the size at base level.
@ -204,15 +206,194 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
casize = max(casize,ione)
casize = casize*40_psb_ipk_
end if
call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info)
else
nplevs = mxplevs
end if
nplevs = max(itwo,min(nplevs,mxplevs))
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
call save_smoothers(p%precv(iszv),coarse_sm,coarse_sm2,info)
if (info == 0) call save_smoothers(p%precv(2),med_sm,med_sm2,info)
if (info == 0) call save_smoothers(p%precv(1),base_sm,base_sm2,info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! First set desired number of levels
!
if (iszv /= nplevs) then
allocate(tprecv(nplevs),stat=info)
! First all existing levels
if (info == 0) tprecv(1)%parms = baseparms
if (info == 0) call restore_smoothers(tprecv(1),p%precv(1)%sm,p%precv(1)%sm2a,info)
do i=2, min(iszv,nplevs) - 1
if (info == 0) tprecv(i)%parms = medparms
if (info == 0) call restore_smoothers(tprecv(i),p%precv(i)%sm,p%precv(i)%sm2a,info)
end do
! Further intermediates, if any
do i=iszv-1, nplevs - 1
if (info == 0) tprecv(i)%parms = medparms
if (info == 0) call restore_smoothers(tprecv(i),med_sm,med_sm2,info)
end do
! Then coarse
if (info == 0) tprecv(nplevs)%parms = coarseparms
if (info == 0) call restore_smoothers(tprecv(nplevs),coarse_sm,coarse_sm2,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,iszv
call p%precv(i)%free(info)
end do
call move_alloc(tprecv,p%precv)
iszv = size(p%precv)
end if
!
! Finest level first; remember to fix base_a and base_desc
!
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
newsz = 0
array_build_loop: do i=2, iszv
!
! Check on the iprcparm contents: they should be the same
! on all processes.
!
call psb_bcast(ictxt,p%precv(i)%parms)
!
! Sanity checks on the parameters
!
if (i<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))
call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info)
end if
! Check for early termination of aggregation loop.
!
iaggsize = sum(nlaggr)
if (iaggsize <= casize) then
newsz = i
end if
if (i>2) then
sizeratio = iaggsize
sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio
if (sizeratio < mnaggratio) then
if (sizeratio > 1) then
newsz = i
else
!
! We are not gaining
!
newsz = i-1
end if
end if
if (all(nlaggr == p%precv(i-1)%map%naggr)) then
newsz=i-1
if (me == 0) then
write(debug_unit,*) trim(name),&
&': Warning: aggregates from level ',&
& newsz
write(debug_unit,*) trim(name),&
&': to level ',&
& iszv,' coincide.'
write(debug_unit,*) trim(name),&
&': Number of levels actually used :',newsz
write(debug_unit,*)
end if
end if
end if
call psb_bcast(ictxt,newsz)
if (newsz > 0) then
if (info == 0) p%precv(newsz)%parms = coarseparms
if (info == 0) call restore_smoothers(p%precv(newsz),coarse_sm,coarse_sm2,info)
if (info == psb_success_) call mld_lev_mat_asb(p%precv(newsz),&
& p%precv(newsz-1)%base_a,p%precv(newsz-1)%base_desc,&
& ilaggr,nlaggr,op_prol,info)
exit array_build_loop
else
if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),&
& p%precv(i-1)%base_a,p%precv(i-1)%base_desc,&
& ilaggr,nlaggr,op_prol,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Map build')
goto 9999
endif
end do array_build_loop
if (newsz > 0) then
!
! We exited early from the build loop, need to fix
! the size.
!
allocate(tprecv(newsz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,newsz
call p%precv(i)%move_alloc(tprecv(i),info)
end do
do i=newsz+1, iszv
call p%precv(i)%free(info)
end do
call move_alloc(tprecv,p%precv)
! Ignore errors from transfer
info = psb_success_
!
! Restart
iszv = newsz
! Fix the pointers, but the level 1 should
! be already OK
do i=2, iszv
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' )
@ -220,7 +401,7 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
endif
iszv = size(p%precv)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
@ -232,4 +413,58 @@ subroutine mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
return
contains
subroutine save_smoothers(level,save1, save2,info)
type(mld_d_onelev_type), intent(in) :: level
class(mld_d_base_smoother_type), allocatable , intent(inout) :: save1, save2
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(save1)) then
call save1%free(info)
if (info == 0) deallocate(save1,stat=info)
if (info /= 0) return
end if
if (allocated(save2)) then
call save2%free(info)
if (info == 0) deallocate(save2,stat=info)
if (info /= 0) return
end if
allocate(save1, source=level%sm,stat=info)
if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info)
return
end subroutine save_smoothers
subroutine restore_smoothers(level,save1, save2,info)
type(mld_d_onelev_type), intent(inout), target :: level
class(mld_d_base_smoother_type), allocatable, intent(in) :: save1, save2
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(level%sm)) then
if (info == 0) call level%sm%free(info)
if (info == 0) deallocate(level%sm,stat=info)
end if
if (allocated(save1)) then
if (info == 0) allocate(level%sm,source=save1,stat=info)
end if
if (info /= 0) return
if (allocated(level%sm2a)) then
if (info == 0) call level%sm2a%free(info)
if (info == 0) deallocate(level%sm2a,stat=info)
end if
if (allocated(save2)) then
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
if (info == 0) level%sm2 => level%sm2a
else
if (allocated(level%sm)) level%sm2 => level%sm
end if
return
end subroutine restore_smoothers
end subroutine mld_d_hierarchy_bld

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.
!!$
!!$
! File: mld_d_ml_prec_bld.f90
! File: mld_d_smoothers_bld.f90
!
! Subroutine: mld_d_ml_prec_bld
! Subroutine: mld_d_smoothers_bld
! Version: real
!
! This routine builds the preconditioner according to the requirements made by
@ -74,11 +74,11 @@
!
!
!
subroutine mld_d_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
subroutine mld_d_smoothers_bld(a,desc_a,p,info,amold,vmold,imold)
use psb_base_mod
use mld_d_inner_mod
use mld_d_prec_mod, mld_protect_name => mld_d_ml_prec_bld
use mld_d_prec_mod, mld_protect_name => mld_d_smoothers_bld
Implicit None
@ -109,7 +109,7 @@ subroutine mld_d_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
name = 'mld_d_ml_prec_bld'
name = 'mld_d_smoothers_bld'
info = psb_success_
int_err(1) = 0
ictxt = desc_a%get_context()
@ -191,4 +191,4 @@ subroutine mld_d_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
return
end subroutine mld_d_ml_prec_bld
end subroutine mld_d_smoothers_bld

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

@ -79,7 +79,7 @@
! info - integer, output.
! Error code.
!
subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod
use mld_d_inner_mod, mld_protect_name => mld_daggrmap_bld
@ -93,13 +93,14 @@ subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_dspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_), allocatable :: ils(:), neigh(:)
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m,naggrm1, naggrp1, ntaggr
type(psb_dspmat_type) :: atmp, atrans
logical :: recovery
type(psb_d_coo_sparse_mat) :: tmpcoo
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
@ -151,6 +152,28 @@ subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
goto 9999
end if
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = done
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_from(tmpcoo)
call psb_erractionrestore(err_act)
return

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

@ -98,7 +98,7 @@
! info - integer, output.
! Error code.
!
subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_asb
@ -109,11 +109,11 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_d_onelev_type), intent(inout), target :: p
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(inout) :: ac, op_prol,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
type(psb_dspmat_type) :: ac, op_prol,op_restr
type(psb_d_coo_sparse_mat) :: acoo, bcoo
type(psb_d_csr_sparse_mat) :: acsr1
integer(psb_ipk_) :: nzl,ntaggr, err_act
@ -133,26 +133,26 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_info(ictxt, me, np)
select case (p%parms%aggr_kind)
select case (parms%aggr_kind)
case (mld_no_smooth_)
call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_smooth_prol_)
call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_biz_prol_)
call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_min_energy_)
call mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case default
info = psb_err_internal_error_
@ -165,116 +165,6 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
ntaggr = sum(nlaggr)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
call ac%mv_to(bcoo)
if (p%parms%clean_zeros) call bcoo%clean_zeros(info)
nzl = bcoo%get_nzeros()
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
goto 9999
end if
if (np>1) then
call op_prol%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call op_prol%mv_from(acsr1)
endif
call op_prol%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
call op_restr%mv_to(acoo)
nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call op_restr%mv_from(acoo)
if (info == psb_success_) call op_restr%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Converting op_restr to local')
goto 9999
end if
end if
!
! Clip to local rows.
!
call op_restr%set_nrows(p%desc_ac%get_local_rows())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if ((info == psb_success_).and.p%parms%clean_zeros) call ac%clean_zeros(info)
if (info == psb_success_) &
& call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! op_restr => PR^T i.e. restriction operator
! op_prol => PR i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,op_restr,op_prol,ilaggr,nlaggr)
if (info == psb_success_) call op_prol%free()
if (info == psb_success_) call op_restr%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act)
return

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_dspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -128,19 +129,8 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
@ -157,17 +147,10 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol)
do i=1,nrow
tmpcoo%val(i) = done
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(nrow)
call tmpcoo%set_dupl(psb_dupl_add_)
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -197,19 +180,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
end if

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_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -167,14 +168,6 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
@ -209,20 +202,10 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = done
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_asb()
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1')
if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
@ -276,7 +259,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call am3%mv_to(acsr3)
! Compute omega_int
ommx = cmplx(dzero,dzero)
ommx = dzero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
@ -316,18 +299,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
!
! Build the smoothed prolongator using the filtered matrix
@ -454,7 +426,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int
ommx = cmplx(dzero,dzero)
ommx = dzero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_dspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -124,34 +125,12 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
ntaggr = sum(nlaggr)
naggrm1=sum(nlaggr(1:me))
do i=1, nrow
ilaggr(i) = ilaggr(i) + naggrm1
end do
call psb_halo(ilaggr,desc_a,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
call acoo%allocate(ncol,ntaggr,ncol)
do i=1,nrow
acoo%val(i) = done
acoo%ia(i) = i
acoo%ja(i) = ilaggr(i)
end do
call acoo%set_dupl(psb_dupl_add_)
call acoo%set_nzeros(nrow)
call acoo%set_asb()
call acoo%fix(info)
call op_prol%mv_from(acoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call op_prol%transp(op_restr)
if (info /= psb_success_) goto 9999
call op_prol%transp(op_restr)
call a%cp_to(ac_coo)
nzt = ac_coo%get_nzeros()

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_dspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -147,14 +148,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
!
! naggr: number of local aggregates
! nrow: local rows.
!
@ -172,17 +166,10 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = done
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -212,19 +199,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
end if

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_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE')
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)

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),&
& 'Entering '
call mld_d_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
call mld_d_hierarchy_bld(a,desc_a,p,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
@ -129,7 +129,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
iszv = p%get_nlevs()
call mld_d_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
call mld_d_smoothers_bld(a,desc_a,p,info,amold,vmold,imold)
if (info /= psb_success_) then
info=psb_err_internal_error_

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_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call p%precv(ilev_)%set(mld_aggr_scale_,scale,info)
call p%precv(ilev_)%set(mld_aggr_filter_,mld_no_filter_mat_,info)
call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info)
end do
case default

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
type(psb_s_csr_sparse_mat) :: acsr
real(psb_spk_) :: cpling, tcl
logical :: recovery, disjoint
logical :: disjoint
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
@ -138,16 +138,14 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end if
end if
enddo
if (ip < 1) then
write(0,*) "Should at least contain the node itself ! "
cycle step1
end if
!
! If the whole strongly coupled neighborhood of I is
! as yet unconnected, turn it into the next aggregate
! as yet unconnected, turn it into the next aggregate.
! Same if ip==0 (in which case, neighborhood only
! contains I even if it does not look from matrix)
!
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1))
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
icnt = icnt + 1
naggr = naggr + 1
@ -207,7 +205,7 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
step3: do ii=1,nr
i = idxs(ii)
if (ilaggr(i) < 0) then
if (ilaggr(i) < 0) then
call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
@ -218,7 +216,7 @@ subroutine mld_s_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
! Find its strongly connected neighbourhood not
! already aggregated, and make it into a new aggregate.
!
cpling = szero
cpling = dzero
ip = 0
do k=1, nz
j = icol(k)

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

@ -62,19 +62,8 @@
! of the preconditioner to be built.
! info - integer, output.
! Error code.
!
! amold - class(psb_s_base_sparse_mat), input, optional
! Mold for the inner format of matrices contained in the
! preconditioner
!
!
! vmold - class(psb_s_base_vect_type), input, optional
! Mold for the inner format of vectors contained in the
! preconditioner
!
!
!
subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
subroutine mld_s_hierarchy_bld(a,desc_a,p,info)
use psb_base_mod
use mld_s_inner_mod
@ -87,16 +76,17 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
type(psb_desc_type), intent(inout), target :: desc_a
type(mld_sprec_type),intent(inout),target :: p
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs
real(psb_spk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_spk_) :: mnaggratio, sizeratio
class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2
type(mld_sml_parms) :: baseparms, medparms, coarseparms
integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:)
type(psb_sspmat_type) :: op_prol
type(mld_s_onelev_type), allocatable :: tprecv(:)
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
@ -191,10 +181,22 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
goto 9999
endif
!
! The strategy:
! 1. The maximum number of levels should be already encoded in the
! size of the array;
! 2. If the user did not specify anything, then a default coarse size
! is generated, and the number of levels is set to the maximum;
! 3. If the number of levels has been specified, make sure it's capped
! at the maximum;
! 4. If the size of the array is different from target number of levels,
! reallocate;
! 5. Build the matrix hierarchy, stopping early if either the target
! coarse size is hit, or the gain falls below the min_aggr_ratio
! threshold.
!
if (nplevs <= 0) then
!
! This should become the default strategy, we specify a target aggregation size.
!
if (casize <=0) then
!
! Default to the cubic root of the size at base level.
@ -204,15 +206,194 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
casize = max(casize,ione)
casize = casize*40_psb_ipk_
end if
call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info)
else
nplevs = mxplevs
end if
nplevs = max(itwo,min(nplevs,mxplevs))
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
call save_smoothers(p%precv(iszv),coarse_sm,coarse_sm2,info)
if (info == 0) call save_smoothers(p%precv(2),med_sm,med_sm2,info)
if (info == 0) call save_smoothers(p%precv(1),base_sm,base_sm2,info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! First set desired number of levels
!
if (iszv /= nplevs) then
allocate(tprecv(nplevs),stat=info)
! First all existing levels
if (info == 0) tprecv(1)%parms = baseparms
if (info == 0) call restore_smoothers(tprecv(1),p%precv(1)%sm,p%precv(1)%sm2a,info)
do i=2, min(iszv,nplevs) - 1
if (info == 0) tprecv(i)%parms = medparms
if (info == 0) call restore_smoothers(tprecv(i),p%precv(i)%sm,p%precv(i)%sm2a,info)
end do
! Further intermediates, if any
do i=iszv-1, nplevs - 1
if (info == 0) tprecv(i)%parms = medparms
if (info == 0) call restore_smoothers(tprecv(i),med_sm,med_sm2,info)
end do
! Then coarse
if (info == 0) tprecv(nplevs)%parms = coarseparms
if (info == 0) call restore_smoothers(tprecv(nplevs),coarse_sm,coarse_sm2,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,iszv
call p%precv(i)%free(info)
end do
call move_alloc(tprecv,p%precv)
iszv = size(p%precv)
end if
!
! Finest level first; remember to fix base_a and base_desc
!
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
newsz = 0
array_build_loop: do i=2, iszv
!
! Check on the iprcparm contents: they should be the same
! on all processes.
!
call psb_bcast(ictxt,p%precv(i)%parms)
!
! Sanity checks on the parameters
!
if (i<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))
call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info)
end if
! Check for early termination of aggregation loop.
!
iaggsize = sum(nlaggr)
if (iaggsize <= casize) then
newsz = i
end if
if (i>2) then
sizeratio = iaggsize
sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio
if (sizeratio < mnaggratio) then
if (sizeratio > 1) then
newsz = i
else
!
! We are not gaining
!
newsz = i-1
end if
end if
if (all(nlaggr == p%precv(i-1)%map%naggr)) then
newsz=i-1
if (me == 0) then
write(debug_unit,*) trim(name),&
&': Warning: aggregates from level ',&
& newsz
write(debug_unit,*) trim(name),&
&': to level ',&
& iszv,' coincide.'
write(debug_unit,*) trim(name),&
&': Number of levels actually used :',newsz
write(debug_unit,*)
end if
end if
end if
call psb_bcast(ictxt,newsz)
if (newsz > 0) then
if (info == 0) p%precv(newsz)%parms = coarseparms
if (info == 0) call restore_smoothers(p%precv(newsz),coarse_sm,coarse_sm2,info)
if (info == psb_success_) call mld_lev_mat_asb(p%precv(newsz),&
& p%precv(newsz-1)%base_a,p%precv(newsz-1)%base_desc,&
& ilaggr,nlaggr,op_prol,info)
exit array_build_loop
else
if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),&
& p%precv(i-1)%base_a,p%precv(i-1)%base_desc,&
& ilaggr,nlaggr,op_prol,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Map build')
goto 9999
endif
end do array_build_loop
if (newsz > 0) then
!
! We exited early from the build loop, need to fix
! the size.
!
allocate(tprecv(newsz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,newsz
call p%precv(i)%move_alloc(tprecv(i),info)
end do
do i=newsz+1, iszv
call p%precv(i)%free(info)
end do
call move_alloc(tprecv,p%precv)
! Ignore errors from transfer
info = psb_success_
!
! Restart
iszv = newsz
! Fix the pointers, but the level 1 should
! be already OK
do i=2, iszv
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' )
@ -220,7 +401,7 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
endif
iszv = size(p%precv)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
@ -232,4 +413,58 @@ subroutine mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
return
contains
subroutine save_smoothers(level,save1, save2,info)
type(mld_s_onelev_type), intent(in) :: level
class(mld_s_base_smoother_type), allocatable , intent(inout) :: save1, save2
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(save1)) then
call save1%free(info)
if (info == 0) deallocate(save1,stat=info)
if (info /= 0) return
end if
if (allocated(save2)) then
call save2%free(info)
if (info == 0) deallocate(save2,stat=info)
if (info /= 0) return
end if
allocate(save1, source=level%sm,stat=info)
if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info)
return
end subroutine save_smoothers
subroutine restore_smoothers(level,save1, save2,info)
type(mld_s_onelev_type), intent(inout), target :: level
class(mld_s_base_smoother_type), allocatable, intent(in) :: save1, save2
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(level%sm)) then
if (info == 0) call level%sm%free(info)
if (info == 0) deallocate(level%sm,stat=info)
end if
if (allocated(save1)) then
if (info == 0) allocate(level%sm,source=save1,stat=info)
end if
if (info /= 0) return
if (allocated(level%sm2a)) then
if (info == 0) call level%sm2a%free(info)
if (info == 0) deallocate(level%sm2a,stat=info)
end if
if (allocated(save2)) then
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
if (info == 0) level%sm2 => level%sm2a
else
if (allocated(level%sm)) level%sm2 => level%sm
end if
return
end subroutine restore_smoothers
end subroutine mld_s_hierarchy_bld

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.
!!$
!!$
! File: mld_s_ml_prec_bld.f90
! File: mld_s_smoothers_bld.f90
!
! Subroutine: mld_s_ml_prec_bld
! Subroutine: mld_s_smoothers_bld
! Version: real
!
! This routine builds the preconditioner according to the requirements made by
@ -74,11 +74,11 @@
!
!
!
subroutine mld_s_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
subroutine mld_s_smoothers_bld(a,desc_a,p,info,amold,vmold,imold)
use psb_base_mod
use mld_s_inner_mod
use mld_s_prec_mod, mld_protect_name => mld_s_ml_prec_bld
use mld_s_prec_mod, mld_protect_name => mld_s_smoothers_bld
Implicit None
@ -109,7 +109,7 @@ subroutine mld_s_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
name = 'mld_s_ml_prec_bld'
name = 'mld_s_smoothers_bld'
info = psb_success_
int_err(1) = 0
ictxt = desc_a%get_context()
@ -191,4 +191,4 @@ subroutine mld_s_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
return
end subroutine mld_s_ml_prec_bld
end subroutine mld_s_smoothers_bld

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

@ -79,7 +79,7 @@
! info - integer, output.
! Error code.
!
subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod
use mld_s_inner_mod, mld_protect_name => mld_saggrmap_bld
@ -93,13 +93,14 @@ subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_sspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_), allocatable :: ils(:), neigh(:)
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m,naggrm1, naggrp1, ntaggr
type(psb_sspmat_type) :: atmp, atrans
logical :: recovery
type(psb_s_coo_sparse_mat) :: tmpcoo
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
@ -151,6 +152,28 @@ subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
goto 9999
end if
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = sone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_from(tmpcoo)
call psb_erractionrestore(err_act)
return

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

@ -98,7 +98,7 @@
! info - integer, output.
! Error code.
!
subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod
use mld_s_inner_mod, mld_protect_name => mld_saggrmat_asb
@ -109,11 +109,11 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_s_onelev_type), intent(inout), target :: p
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(inout) :: ac, op_prol,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
type(psb_sspmat_type) :: ac, op_prol,op_restr
type(psb_s_coo_sparse_mat) :: acoo, bcoo
type(psb_s_csr_sparse_mat) :: acsr1
integer(psb_ipk_) :: nzl,ntaggr, err_act
@ -133,26 +133,26 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_info(ictxt, me, np)
select case (p%parms%aggr_kind)
select case (parms%aggr_kind)
case (mld_no_smooth_)
call mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_smooth_prol_)
call mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_biz_prol_)
call mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_min_energy_)
call mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case default
info = psb_err_internal_error_
@ -165,116 +165,6 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
ntaggr = sum(nlaggr)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
call ac%mv_to(bcoo)
if (p%parms%clean_zeros) call bcoo%clean_zeros(info)
nzl = bcoo%get_nzeros()
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
goto 9999
end if
if (np>1) then
call op_prol%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call op_prol%mv_from(acsr1)
endif
call op_prol%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
call op_restr%mv_to(acoo)
nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call op_restr%mv_from(acoo)
if (info == psb_success_) call op_restr%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Converting op_restr to local')
goto 9999
end if
end if
!
! Clip to local rows.
!
call op_restr%set_nrows(p%desc_ac%get_local_rows())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if ((info == psb_success_).and.p%parms%clean_zeros) call ac%clean_zeros(info)
if (info == psb_success_) &
& call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! op_restr => PR^T i.e. restriction operator
! op_prol => PR i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,op_restr,op_prol,ilaggr,nlaggr)
if (info == psb_success_) call op_prol%free()
if (info == psb_success_) call op_restr%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act)
return

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_sspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -128,19 +129,8 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
@ -157,17 +147,10 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol)
do i=1,nrow
tmpcoo%val(i) = sone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(nrow)
call tmpcoo%set_dupl(psb_dupl_add_)
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -197,19 +180,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
end if

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_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -167,14 +168,6 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
@ -209,20 +202,10 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = sone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_asb()
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1')
if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
@ -276,7 +259,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call am3%mv_to(acsr3)
! Compute omega_int
ommx = cmplx(szero,szero)
ommx = szero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
@ -316,18 +299,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
!
! Build the smoothed prolongator using the filtered matrix
@ -454,7 +426,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int
ommx = cmplx(szero,szero)
ommx = szero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_sspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -124,34 +125,12 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
ntaggr = sum(nlaggr)
naggrm1=sum(nlaggr(1:me))
do i=1, nrow
ilaggr(i) = ilaggr(i) + naggrm1
end do
call psb_halo(ilaggr,desc_a,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
call acoo%allocate(ncol,ntaggr,ncol)
do i=1,nrow
acoo%val(i) = sone
acoo%ia(i) = i
acoo%ja(i) = ilaggr(i)
end do
call acoo%set_dupl(psb_dupl_add_)
call acoo%set_nzeros(nrow)
call acoo%set_asb()
call acoo%fix(info)
call op_prol%mv_from(acoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call op_prol%transp(op_restr)
if (info /= psb_success_) goto 9999
call op_prol%transp(op_restr)
call a%cp_to(ac_coo)
nzt = ac_coo%get_nzeros()

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_sspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -147,14 +148,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
!
! naggr: number of local aggregates
! nrow: local rows.
!
@ -172,17 +166,10 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = sone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -212,19 +199,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
end if

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_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE')
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)

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),&
& 'Entering '
call mld_s_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
call mld_s_hierarchy_bld(a,desc_a,p,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
@ -129,7 +129,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold)
iszv = p%get_nlevs()
call mld_s_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
call mld_s_smoothers_bld(a,desc_a,p,info,amold,vmold,imold)
if (info /= psb_success_) then
info=psb_err_internal_error_

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_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call p%precv(ilev_)%set(mld_aggr_scale_,scale,info)
call p%precv(ilev_)%set(mld_aggr_filter_,mld_no_filter_mat_,info)
call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info)
end do
case default

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
type(psb_z_csr_sparse_mat) :: acsr
real(psb_dpk_) :: cpling, tcl
logical :: recovery, disjoint
logical :: disjoint
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
@ -138,16 +138,14 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end if
end if
enddo
if (ip < 1) then
write(0,*) "Should at least contain the node itself ! "
cycle step1
end if
!
! If the whole strongly coupled neighborhood of I is
! as yet unconnected, turn it into the next aggregate
! as yet unconnected, turn it into the next aggregate.
! Same if ip==0 (in which case, neighborhood only
! contains I even if it does not look from matrix)
!
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1))
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
icnt = icnt + 1
naggr = naggr + 1
@ -207,7 +205,7 @@ subroutine mld_z_dec_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
step3: do ii=1,nr
i = idxs(ii)
if (ilaggr(i) < 0) then
if (ilaggr(i) < 0) then
call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_

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

@ -62,19 +62,8 @@
! of the preconditioner to be built.
! info - integer, output.
! Error code.
!
! amold - class(psb_z_base_sparse_mat), input, optional
! Mold for the inner format of matrices contained in the
! preconditioner
!
!
! vmold - class(psb_z_base_vect_type), input, optional
! Mold for the inner format of vectors contained in the
! preconditioner
!
!
!
subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
subroutine mld_z_hierarchy_bld(a,desc_a,p,info)
use psb_base_mod
use mld_z_inner_mod
@ -87,16 +76,17 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
type(psb_desc_type), intent(inout), target :: desc_a
type(mld_zprec_type),intent(inout),target :: p
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_sparse_mat), intent(in), optional :: amold
class(psb_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
!!$ character, intent(in), optional :: upd
! Local Variables
integer(psb_ipk_) :: ictxt, me,np
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs
real(psb_dpk_) :: mnaggratio
integer(psb_ipk_) :: ipv(mld_ifpsz_), val
integer(psb_ipk_) :: err,i,k, err_act, iszv, newsz, casize, nplevs, mxplevs, iaggsize
real(psb_dpk_) :: mnaggratio, sizeratio
class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm, base_sm2, med_sm2, coarse_sm2
type(mld_dml_parms) :: baseparms, medparms, coarseparms
integer(psb_ipk_), allocatable :: ilaggr(:), nlaggr(:)
type(psb_zspmat_type) :: op_prol
type(mld_z_onelev_type), allocatable :: tprecv(:)
integer(psb_ipk_) :: int_err(5)
character :: upd_
integer(psb_ipk_) :: debug_level, debug_unit
@ -191,10 +181,22 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
goto 9999
endif
!
! The strategy:
! 1. The maximum number of levels should be already encoded in the
! size of the array;
! 2. If the user did not specify anything, then a default coarse size
! is generated, and the number of levels is set to the maximum;
! 3. If the number of levels has been specified, make sure it's capped
! at the maximum;
! 4. If the size of the array is different from target number of levels,
! reallocate;
! 5. Build the matrix hierarchy, stopping early if either the target
! coarse size is hit, or the gain falls below the min_aggr_ratio
! threshold.
!
if (nplevs <= 0) then
!
! This should become the default strategy, we specify a target aggregation size.
!
if (casize <=0) then
!
! Default to the cubic root of the size at base level.
@ -204,15 +206,194 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
casize = max(casize,ione)
casize = casize*40_psb_ipk_
end if
call mld_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,p%precv,info)
else
nplevs = mxplevs
end if
nplevs = max(itwo,min(nplevs,mxplevs))
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
call save_smoothers(p%precv(iszv),coarse_sm,coarse_sm2,info)
if (info == 0) call save_smoothers(p%precv(2),med_sm,med_sm2,info)
if (info == 0) call save_smoothers(p%precv(1),base_sm,base_sm2,info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! First set desired number of levels
!
if (iszv /= nplevs) then
allocate(tprecv(nplevs),stat=info)
! First all existing levels
if (info == 0) tprecv(1)%parms = baseparms
if (info == 0) call restore_smoothers(tprecv(1),p%precv(1)%sm,p%precv(1)%sm2a,info)
do i=2, min(iszv,nplevs) - 1
if (info == 0) tprecv(i)%parms = medparms
if (info == 0) call restore_smoothers(tprecv(i),p%precv(i)%sm,p%precv(i)%sm2a,info)
end do
! Further intermediates, if any
do i=iszv-1, nplevs - 1
if (info == 0) tprecv(i)%parms = medparms
if (info == 0) call restore_smoothers(tprecv(i),med_sm,med_sm2,info)
end do
! Then coarse
if (info == 0) tprecv(nplevs)%parms = coarseparms
if (info == 0) call restore_smoothers(tprecv(nplevs),coarse_sm,coarse_sm2,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,iszv
call p%precv(i)%free(info)
end do
call move_alloc(tprecv,p%precv)
iszv = size(p%precv)
end if
!
! Finest level first; remember to fix base_a and base_desc
!
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
newsz = 0
array_build_loop: do i=2, iszv
!
! Check on the iprcparm contents: they should be the same
! on all processes.
!
call psb_bcast(ictxt,p%precv(i)%parms)
!
! Sanity checks on the parameters
!
if (i<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))
call mld_bld_mlhier_array(nplevs,a,desc_a,p%precv,info)
end if
! Check for early termination of aggregation loop.
!
iaggsize = sum(nlaggr)
if (iaggsize <= casize) then
newsz = i
end if
if (i>2) then
sizeratio = iaggsize
sizeratio = sum(p%precv(i-1)%map%naggr)/sizeratio
if (sizeratio < mnaggratio) then
if (sizeratio > 1) then
newsz = i
else
!
! We are not gaining
!
newsz = i-1
end if
end if
if (all(nlaggr == p%precv(i-1)%map%naggr)) then
newsz=i-1
if (me == 0) then
write(debug_unit,*) trim(name),&
&': Warning: aggregates from level ',&
& newsz
write(debug_unit,*) trim(name),&
&': to level ',&
& iszv,' coincide.'
write(debug_unit,*) trim(name),&
&': Number of levels actually used :',newsz
write(debug_unit,*)
end if
end if
end if
call psb_bcast(ictxt,newsz)
if (newsz > 0) then
if (info == 0) p%precv(newsz)%parms = coarseparms
if (info == 0) call restore_smoothers(p%precv(newsz),coarse_sm,coarse_sm2,info)
if (info == psb_success_) call mld_lev_mat_asb(p%precv(newsz),&
& p%precv(newsz-1)%base_a,p%precv(newsz-1)%base_desc,&
& ilaggr,nlaggr,op_prol,info)
exit array_build_loop
else
if (info == psb_success_) call mld_lev_mat_asb(p%precv(i),&
& p%precv(i-1)%base_a,p%precv(i-1)%base_desc,&
& ilaggr,nlaggr,op_prol,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Map build')
goto 9999
endif
end do array_build_loop
if (newsz > 0) then
!
! We exited early from the build loop, need to fix
! the size.
!
allocate(tprecv(newsz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,newsz
call p%precv(i)%move_alloc(tprecv(i),info)
end do
do i=newsz+1, iszv
call p%precv(i)%free(info)
end do
call move_alloc(tprecv,p%precv)
! Ignore errors from transfer
info = psb_success_
!
! Restart
iszv = newsz
! Fix the pointers, but the level 1 should
! be already OK
do i=2, iszv
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Internal hierarchy build' )
@ -220,7 +401,7 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
endif
iszv = size(p%precv)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Exiting with',iszv,' levels'
@ -232,4 +413,58 @@ subroutine mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
return
contains
subroutine save_smoothers(level,save1, save2,info)
type(mld_z_onelev_type), intent(in) :: level
class(mld_z_base_smoother_type), allocatable , intent(inout) :: save1, save2
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(save1)) then
call save1%free(info)
if (info == 0) deallocate(save1,stat=info)
if (info /= 0) return
end if
if (allocated(save2)) then
call save2%free(info)
if (info == 0) deallocate(save2,stat=info)
if (info /= 0) return
end if
allocate(save1, source=level%sm,stat=info)
if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info)
return
end subroutine save_smoothers
subroutine restore_smoothers(level,save1, save2,info)
type(mld_z_onelev_type), intent(inout), target :: level
class(mld_z_base_smoother_type), allocatable, intent(in) :: save1, save2
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(level%sm)) then
if (info == 0) call level%sm%free(info)
if (info == 0) deallocate(level%sm,stat=info)
end if
if (allocated(save1)) then
if (info == 0) allocate(level%sm,source=save1,stat=info)
end if
if (info /= 0) return
if (allocated(level%sm2a)) then
if (info == 0) call level%sm2a%free(info)
if (info == 0) deallocate(level%sm2a,stat=info)
end if
if (allocated(save2)) then
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
if (info == 0) level%sm2 => level%sm2a
else
if (allocated(level%sm)) level%sm2 => level%sm
end if
return
end subroutine restore_smoothers
end subroutine mld_z_hierarchy_bld

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.
!!$
!!$
! File: mld_z_ml_prec_bld.f90
! File: mld_z_smoothers_bld.f90
!
! Subroutine: mld_z_ml_prec_bld
! Subroutine: mld_z_smoothers_bld
! Version: complex
!
! This routine builds the preconditioner according to the requirements made by
@ -74,11 +74,11 @@
!
!
!
subroutine mld_z_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
subroutine mld_z_smoothers_bld(a,desc_a,p,info,amold,vmold,imold)
use psb_base_mod
use mld_z_inner_mod
use mld_z_prec_mod, mld_protect_name => mld_z_ml_prec_bld
use mld_z_prec_mod, mld_protect_name => mld_z_smoothers_bld
Implicit None
@ -109,7 +109,7 @@ subroutine mld_z_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
name = 'mld_z_ml_prec_bld'
name = 'mld_z_smoothers_bld'
info = psb_success_
int_err(1) = 0
ictxt = desc_a%get_context()
@ -191,4 +191,4 @@ subroutine mld_z_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
return
end subroutine mld_z_ml_prec_bld
end subroutine mld_z_smoothers_bld

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

@ -79,7 +79,7 @@
! info - integer, output.
! Error code.
!
subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod
use mld_z_inner_mod, mld_protect_name => mld_zaggrmap_bld
@ -93,13 +93,14 @@ subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_zspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_), allocatable :: ils(:), neigh(:)
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m,naggrm1, naggrp1, ntaggr
type(psb_zspmat_type) :: atmp, atrans
logical :: recovery
type(psb_z_coo_sparse_mat) :: tmpcoo
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
@ -151,6 +152,28 @@ subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
goto 9999
end if
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = zone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_from(tmpcoo)
call psb_erractionrestore(err_act)
return

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

@ -98,7 +98,7 @@
! info - integer, output.
! Error code.
!
subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod
use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_asb
@ -109,11 +109,11 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_z_onelev_type), intent(inout), target :: p
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(inout) :: ac, op_prol,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
type(psb_zspmat_type) :: ac, op_prol,op_restr
type(psb_z_coo_sparse_mat) :: acoo, bcoo
type(psb_z_csr_sparse_mat) :: acsr1
integer(psb_ipk_) :: nzl,ntaggr, err_act
@ -133,26 +133,26 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_info(ictxt, me, np)
select case (p%parms%aggr_kind)
select case (parms%aggr_kind)
case (mld_no_smooth_)
call mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_smooth_prol_)
call mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_biz_prol_)
call mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case(mld_min_energy_)
call mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
& parms,ac,op_prol,op_restr,info)
case default
info = psb_err_internal_error_
@ -165,116 +165,6 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999
end if
ntaggr = sum(nlaggr)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
call ac%mv_to(bcoo)
if (p%parms%clean_zeros) call bcoo%clean_zeros(info)
nzl = bcoo%get_nzeros()
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
goto 9999
end if
if (np>1) then
call op_prol%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call op_prol%mv_from(acsr1)
endif
call op_prol%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
call op_restr%mv_to(acoo)
nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call op_restr%mv_from(acoo)
if (info == psb_success_) call op_restr%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Converting op_restr to local')
goto 9999
end if
end if
!
! Clip to local rows.
!
call op_restr%set_nrows(p%desc_ac%get_local_rows())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if ((info == psb_success_).and.p%parms%clean_zeros) call ac%clean_zeros(info)
if (info == psb_success_) &
& call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! op_restr => PR^T i.e. restriction operator
! op_prol => PR i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,op_restr,op_prol,ilaggr,nlaggr)
if (info == psb_success_) call op_prol%free()
if (info == psb_success_) call op_restr%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act)
return

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_zspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -128,19 +129,8 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
@ -157,17 +147,10 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol)
do i=1,nrow
tmpcoo%val(i) = zone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(nrow)
call tmpcoo%set_dupl(psb_dupl_add_)
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -197,19 +180,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
end if

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_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -167,14 +168,6 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
@ -209,20 +202,10 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = zone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_asb()
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1')
if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
@ -276,7 +259,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call am3%mv_to(acsr3)
! Compute omega_int
ommx = cmplx(dzero,dzero)
ommx = zzero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
@ -316,18 +299,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
!
! Build the smoothed prolongator using the filtered matrix
@ -454,7 +426,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int
ommx = cmplx(dzero,dzero)
ommx = zzero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_zspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -124,34 +125,12 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
ntaggr = sum(nlaggr)
naggrm1=sum(nlaggr(1:me))
do i=1, nrow
ilaggr(i) = ilaggr(i) + naggrm1
end do
call psb_halo(ilaggr,desc_a,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
call acoo%allocate(ncol,ntaggr,ncol)
do i=1,nrow
acoo%val(i) = zone
acoo%ia(i) = i
acoo%ja(i) = ilaggr(i)
end do
call acoo%set_dupl(psb_dupl_add_)
call acoo%set_nzeros(nrow)
call acoo%set_asb()
call acoo%fix(info)
call op_prol%mv_from(acoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call op_prol%transp(op_restr)
if (info /= psb_success_) goto 9999
call op_prol%transp(op_restr)
call a%cp_to(ac_coo)
nzt = ac_coo%get_nzeros()

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
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
type(psb_zspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
@ -147,14 +148,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
!
! naggr: number of local aggregates
! nrow: local rows.
!
@ -172,17 +166,10 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol
tmpcoo%val(i) = zone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -212,19 +199,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
call acsrf%clean_zeros(info)
end if

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_
call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos)
case('AGGR_SCALE')
do ilev_ = 2, nlev_
call p%precv(ilev_)%set('AGGR_SCALE',val,info,pos=pos)

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),&
& 'Entering '
call mld_z_hierarchy_bld(a,desc_a,p,info,amold,vmold,imold)
call mld_z_hierarchy_bld(a,desc_a,p,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
@ -129,7 +129,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
iszv = p%get_nlevs()
call mld_z_ml_prec_bld(a,desc_a,p,info,amold,vmold,imold)
call mld_z_smoothers_bld(a,desc_a,p,info,amold,vmold,imold)
if (info /= psb_success_) then
info=psb_err_internal_error_

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_
call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info)
call p%precv(ilev_)%set(mld_aggr_scale_,scale,info)
call p%precv(ilev_)%set(mld_aggr_filter_,mld_no_filter_mat_,info)
call p%precv(ilev_)%set(mld_aggr_filter_,mld_filter_mat_,info)
end do
case default

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

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 interface mld_mlprec_bld
interface mld_mlprec_aply
subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_
@ -95,20 +94,6 @@ module mld_c_inner_mod
end subroutine mld_cmlprec_aply_vect
end interface mld_mlprec_aply
interface mld_coarse_bld
subroutine mld_ccoarse_bld(a,desc_a,p,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_c_prec_type, only : mld_c_onelev_type
implicit none
type(psb_cspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_c_onelev_type), intent(inout), target :: p
integer(psb_ipk_), intent(out) :: info
end subroutine mld_ccoarse_bld
end interface mld_coarse_bld
interface mld_bld_mlhier_aggsize
subroutine mld_c_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type,psb_spk_
@ -124,11 +109,12 @@ module mld_c_inner_mod
end interface mld_bld_mlhier_aggsize
interface mld_bld_mlhier_array
subroutine mld_c_bld_mlhier_array(nplevs,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type
subroutine mld_c_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_c_onelev_type
implicit none
integer(psb_ipk_), intent(inout) :: nplevs
integer(psb_ipk_), intent(inout) :: nplevs, casize
real(psb_spk_) :: mnaggratio
type(psb_cspmat_type),intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a
type(mld_c_onelev_type), allocatable, target, intent(inout) :: precv(:)
@ -137,7 +123,18 @@ module mld_c_inner_mod
end interface mld_bld_mlhier_array
interface mld_aggrmap_bld
subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
subroutine mld_c_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_c_prec_type, only : mld_c_onelev_type
implicit none
type(mld_c_onelev_type), intent(inout), target :: p
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: ilaggr(:),nlaggr(:)
type(psb_cspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_c_lev_aggrmap_bld
subroutine mld_caggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: iorder
@ -146,6 +143,7 @@ module mld_c_inner_mod
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_cspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_caggrmap_bld
end interface mld_aggrmap_bld
@ -165,15 +163,30 @@ module mld_c_inner_mod
end interface mld_dec_map_bld
interface mld_aggrmat_asb
subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
interface mld_lev_mat_asb
subroutine mld_c_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_c_prec_type, only : mld_c_onelev_type
implicit none
type(mld_c_onelev_type), intent(inout), target :: p
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:)
type(psb_cspmat_type), intent(inout) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_c_lev_aggrmat_asb
end interface mld_lev_mat_asb
interface mld_aggrmat_asb
subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_c_prec_type, only : mld_sml_parms
implicit none
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_c_onelev_type), intent(inout), target :: p
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
integer(psb_ipk_), intent(out) :: info
end subroutine mld_caggrmat_asb
end interface mld_aggrmat_asb

16
mlprec/mld_c_prec_mod.f90
Unescape Escape View File

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

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 interface mld_mlprec_bld
interface mld_mlprec_aply
subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
@ -95,20 +94,6 @@ module mld_d_inner_mod
end subroutine mld_dmlprec_aply_vect
end interface mld_mlprec_aply
interface mld_coarse_bld
subroutine mld_dcoarse_bld(a,desc_a,p,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_d_prec_type, only : mld_d_onelev_type
implicit none
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_d_onelev_type), intent(inout), target :: p
integer(psb_ipk_), intent(out) :: info
end subroutine mld_dcoarse_bld
end interface mld_coarse_bld
interface mld_bld_mlhier_aggsize
subroutine mld_d_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type,psb_dpk_
@ -124,11 +109,12 @@ module mld_d_inner_mod
end interface mld_bld_mlhier_aggsize
interface mld_bld_mlhier_array
subroutine mld_d_bld_mlhier_array(nplevs,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type
subroutine mld_d_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_d_onelev_type
implicit none
integer(psb_ipk_), intent(inout) :: nplevs
integer(psb_ipk_), intent(inout) :: nplevs, casize
real(psb_dpk_) :: mnaggratio
type(psb_dspmat_type),intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a
type(mld_d_onelev_type), allocatable, target, intent(inout) :: precv(:)
@ -137,7 +123,18 @@ module mld_d_inner_mod
end interface mld_bld_mlhier_array
interface mld_aggrmap_bld
subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
subroutine mld_d_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_d_prec_type, only : mld_d_onelev_type
implicit none
type(mld_d_onelev_type), intent(inout), target :: p
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: ilaggr(:),nlaggr(:)
type(psb_dspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_d_lev_aggrmap_bld
subroutine mld_daggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: iorder
@ -146,6 +143,7 @@ module mld_d_inner_mod
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_dspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_daggrmap_bld
end interface mld_aggrmap_bld
@ -165,15 +163,30 @@ module mld_d_inner_mod
end interface mld_dec_map_bld
interface mld_aggrmat_asb
subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
interface mld_lev_mat_asb
subroutine mld_d_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_d_prec_type, only : mld_d_onelev_type
implicit none
type(mld_d_onelev_type), intent(inout), target :: p
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:)
type(psb_dspmat_type), intent(inout) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_d_lev_aggrmat_asb
end interface mld_lev_mat_asb
interface mld_aggrmat_asb
subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_d_prec_type, only : mld_dml_parms
implicit none
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_d_onelev_type), intent(inout), target :: p
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
integer(psb_ipk_), intent(out) :: info
end subroutine mld_daggrmat_asb
end interface mld_aggrmat_asb

16
mlprec/mld_d_prec_mod.f90
Unescape Escape View File

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

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 interface mld_mlprec_bld
interface mld_mlprec_aply
subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_
@ -95,20 +94,6 @@ module mld_s_inner_mod
end subroutine mld_smlprec_aply_vect
end interface mld_mlprec_aply
interface mld_coarse_bld
subroutine mld_scoarse_bld(a,desc_a,p,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_s_prec_type, only : mld_s_onelev_type
implicit none
type(psb_sspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_s_onelev_type), intent(inout), target :: p
integer(psb_ipk_), intent(out) :: info
end subroutine mld_scoarse_bld
end interface mld_coarse_bld
interface mld_bld_mlhier_aggsize
subroutine mld_s_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type,psb_spk_
@ -124,11 +109,12 @@ module mld_s_inner_mod
end interface mld_bld_mlhier_aggsize
interface mld_bld_mlhier_array
subroutine mld_s_bld_mlhier_array(nplevs,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type
subroutine mld_s_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_s_onelev_type
implicit none
integer(psb_ipk_), intent(inout) :: nplevs
integer(psb_ipk_), intent(inout) :: nplevs, casize
real(psb_spk_) :: mnaggratio
type(psb_sspmat_type),intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a
type(mld_s_onelev_type), allocatable, target, intent(inout) :: precv(:)
@ -137,7 +123,18 @@ module mld_s_inner_mod
end interface mld_bld_mlhier_array
interface mld_aggrmap_bld
subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
subroutine mld_s_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_s_prec_type, only : mld_s_onelev_type
implicit none
type(mld_s_onelev_type), intent(inout), target :: p
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: ilaggr(:),nlaggr(:)
type(psb_sspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_s_lev_aggrmap_bld
subroutine mld_saggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: iorder
@ -146,6 +143,7 @@ module mld_s_inner_mod
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_sspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_saggrmap_bld
end interface mld_aggrmap_bld
@ -165,15 +163,30 @@ module mld_s_inner_mod
end interface mld_dec_map_bld
interface mld_aggrmat_asb
subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
interface mld_lev_mat_asb
subroutine mld_s_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_s_prec_type, only : mld_s_onelev_type
implicit none
type(mld_s_onelev_type), intent(inout), target :: p
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:)
type(psb_sspmat_type), intent(inout) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_s_lev_aggrmat_asb
end interface mld_lev_mat_asb
interface mld_aggrmat_asb
subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_
use mld_s_prec_type, only : mld_sml_parms
implicit none
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_s_onelev_type), intent(inout), target :: p
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
integer(psb_ipk_), intent(out) :: info
end subroutine mld_saggrmat_asb
end interface mld_aggrmat_asb

16
mlprec/mld_s_prec_mod.f90
Unescape Escape View File

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

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 interface mld_mlprec_bld
interface mld_mlprec_aply
subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
@ -95,20 +94,6 @@ module mld_z_inner_mod
end subroutine mld_zmlprec_aply_vect
end interface mld_mlprec_aply
interface mld_coarse_bld
subroutine mld_zcoarse_bld(a,desc_a,p,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_z_prec_type, only : mld_z_onelev_type
implicit none
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_z_onelev_type), intent(inout), target :: p
integer(psb_ipk_), intent(out) :: info
end subroutine mld_zcoarse_bld
end interface mld_coarse_bld
interface mld_bld_mlhier_aggsize
subroutine mld_z_bld_mlhier_aggsize(casize,mxplevs,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type,psb_dpk_
@ -124,11 +109,12 @@ module mld_z_inner_mod
end interface mld_bld_mlhier_aggsize
interface mld_bld_mlhier_array
subroutine mld_z_bld_mlhier_array(nplevs,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type
subroutine mld_z_bld_mlhier_array(nplevs,casize,mnaggratio,a,desc_a,precv,info)
use psb_base_mod, only : psb_ipk_, psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_z_onelev_type
implicit none
integer(psb_ipk_), intent(inout) :: nplevs
integer(psb_ipk_), intent(inout) :: nplevs, casize
real(psb_dpk_) :: mnaggratio
type(psb_zspmat_type),intent(in), target :: a
type(psb_desc_type), intent(inout), target :: desc_a
type(mld_z_onelev_type), allocatable, target, intent(inout) :: precv(:)
@ -137,7 +123,18 @@ module mld_z_inner_mod
end interface mld_bld_mlhier_array
interface mld_aggrmap_bld
subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,info)
subroutine mld_z_lev_aggrmap_bld(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_z_prec_type, only : mld_z_onelev_type
implicit none
type(mld_z_onelev_type), intent(inout), target :: p
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: ilaggr(:),nlaggr(:)
type(psb_zspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_z_lev_aggrmap_bld
subroutine mld_zaggrmap_bld(aggr_type,iorder,theta,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
implicit none
integer(psb_ipk_), intent(in) :: iorder
@ -146,6 +143,7 @@ module mld_z_inner_mod
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_zspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_zaggrmap_bld
end interface mld_aggrmap_bld
@ -165,15 +163,30 @@ module mld_z_inner_mod
end interface mld_dec_map_bld
interface mld_aggrmat_asb
subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
interface mld_lev_mat_asb
subroutine mld_z_lev_aggrmat_asb(p,a,desc_a,ilaggr,nlaggr,op_prol,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_z_prec_type, only : mld_z_onelev_type
implicit none
type(mld_z_onelev_type), intent(inout), target :: p
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:),nlaggr(:)
type(psb_zspmat_type), intent(inout) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine mld_z_lev_aggrmat_asb
end interface mld_lev_mat_asb
interface mld_aggrmat_asb
subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
use mld_z_prec_type, only : mld_dml_parms
implicit none
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_z_onelev_type), intent(inout), target :: p
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
integer(psb_ipk_), intent(out) :: info
end subroutine mld_zaggrmat_asb
end interface mld_aggrmat_asb

16
mlprec/mld_z_prec_mod.f90
Unescape Escape View File

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

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
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3)
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.4)
!!$
!!$ (C) Copyright 2008, 2010, 2012, 2015
!!$
@ -69,34 +69,34 @@ contains
! functions parametrizing the differential equation
!
function b1(x,y)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: b1
real(psb_dpk_), intent(in) :: x,y
b1=0.d0/sqrt(2.d0)
b1=dzero/sqrt((2*done))
end function b1
function b2(x,y)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: b2
real(psb_dpk_), intent(in) :: x,y
b2=0.d0/sqrt(2.d0)
b2=dzero/sqrt((2*done))
end function b2
function c(x,y)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: c
real(psb_dpk_), intent(in) :: x,y
c=0.d0
c=dzero
end function c
function a1(x,y)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: a1
real(psb_dpk_), intent(in) :: x,y
a1=1.d0!/80
a1=done!/80
end function a1
function a2(x,y)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: a2
real(psb_dpk_), intent(in) :: x,y
a2=1.d0!/80
a2=done!/80
end function a2
function g(x,y)
use psb_base_mod, only : psb_dpk_, done, dzero
@ -160,6 +160,7 @@ program mld_d_pde2d
character(len=16) :: aggrkind ! smoothed/raw aggregatin
character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: aggr_ord ! Ordering for aggregation
character(len=16) :: aggr_filter ! Use filtering?
character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing
integer(psb_ipk_) :: csize ! aggregation size at which to stop.
@ -175,6 +176,8 @@ program mld_d_pde2d
type(precdata) :: prectype
type(psb_d_coo_sparse_mat) :: acoo
! other variables
logical :: dump_prec
character(len=40) :: dump_prefix
integer(psb_ipk_) :: info, i
character(len=20) :: name,ch_err
@ -203,7 +206,8 @@ program mld_d_pde2d
!
! get parameters
!
call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps)
call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,&
& dump_prec,dump_prefix)
!
! allocate and fill in the coefficient matrix, rhs and initial guess
@ -246,6 +250,7 @@ program mld_d_pde2d
call mld_precset(prec,'aggr_kind', prectype%aggrkind,info)
call mld_precset(prec,'aggr_alg', prectype%aggr_alg,info)
call mld_precset(prec,'aggr_ord', prectype%aggr_ord,info)
call mld_precset(prec,'aggr_filter', prectype%aggr_filter, info)
call psb_barrier(ictxt)
t1 = psb_wtime()
@ -368,6 +373,10 @@ program mld_d_pde2d
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize
end if
if (dump_prec) call prec%dump(info,prefix=trim(dump_prefix),&
& ac=.true.,solver=.true.,smoother=.true.,rp=.true.,global_num=.true.)
!
! cleanup storage and exit
!
@ -392,13 +401,17 @@ contains
!
! get iteration parameters from standard input
!
subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps)
subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,&
& dump_prec,dump_prefix)
integer(psb_ipk_) :: ictxt
type(precdata) :: prectype
character(len=*) :: kmethd, afmt
integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst
integer(psb_ipk_) :: np, iam, info
real(psb_dpk_) :: eps
logical :: dump_prec
character(len=*) :: dump_prefix
character(len=20) :: buffer
call psb_info(ictxt, iam, np)
@ -412,6 +425,8 @@ contains
call read_data(itrace,psb_inp_unit)
call read_data(irst,psb_inp_unit)
call read_data(eps,psb_inp_unit)
call read_data(dump_prec,psb_inp_unit)
call read_data(dump_prefix,psb_inp_unit)
call read_data(prectype%descr,psb_inp_unit) ! verbose description of the prec
call read_data(prectype%prec,psb_inp_unit) ! overall prectype
call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels
@ -422,6 +437,7 @@ contains
call read_data(prectype%aggrkind,psb_inp_unit) ! smoothed/nonsmoothed/minenergy aggregatin
call read_data(prectype%aggr_alg,psb_inp_unit) ! decoupled or sym. decoupled aggregation
call read_data(prectype%aggr_ord,psb_inp_unit) ! aggregation ordering: natural, node degree
call read_data(prectype%aggr_filter,psb_inp_unit) ! aggregation filtering: filter, no_filter
call read_data(prectype%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec
call read_data(prectype%smthpos,psb_inp_unit) ! side: pre, post, both smoothing
call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps
@ -450,6 +466,8 @@ contains
call psb_bcast(ictxt,itrace)
call psb_bcast(ictxt,irst)
call psb_bcast(ictxt,eps)
call psb_bcast(ictxt,dump_prec)
call psb_bcast(ictxt,dump_prefix)
call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec
call psb_bcast(ictxt,prectype%prec) ! overall prectype
call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels
@ -460,6 +478,7 @@ contains
call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin
call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation
call psb_bcast(ictxt,prectype%aggr_ord) ! aggregation ordering: natural, node degree
call psb_bcast(ictxt,prectype%aggr_filter) ! aggregation filtering: filter, no_filter
call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec
call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing
call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps

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

@ -68,49 +68,49 @@ contains
! functions parametrizing the differential equation
!
function b1(x,y,z)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: b1
real(psb_dpk_), intent(in) :: x,y,z
b1=0.d0/sqrt(3.d0)
b1=dzero/sqrt((3*done))
end function b1
function b2(x,y,z)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: b2
real(psb_dpk_), intent(in) :: x,y,z
b2=0.d0/sqrt(3.d0)
b2=dzero/sqrt((3*done))
end function b2
function b3(x,y,z)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: b3
real(psb_dpk_), intent(in) :: x,y,z
b3=0.d0/sqrt(3.d0)
b3=dzero/sqrt((3*done))
end function b3
function c(x,y,z)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: c
real(psb_dpk_), intent(in) :: x,y,z
c=0.d0
c=dzero
end function c
function a1(x,y,z)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: a1
real(psb_dpk_), intent(in) :: x,y,z
a1=1.d0!/80
a1=done!/80
end function a1
function a2(x,y,z)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: a2
real(psb_dpk_), intent(in) :: x,y,z
a2=1.d0!/80
a2=done!/80
end function a2
function a3(x,y,z)
use psb_base_mod, only : psb_dpk_
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: a3
real(psb_dpk_), intent(in) :: x,y,z
a3=1.d0!/80
a3=done!/80
end function a3
function g(x,y,z)
use psb_base_mod, only : psb_dpk_, done, dzero
use psb_base_mod, only : psb_dpk_,done,dzero
real(psb_dpk_) :: g
real(psb_dpk_), intent(in) :: x,y,z
g = dzero
@ -171,6 +171,7 @@ program mld_d_pde3d
character(len=16) :: aggrkind ! smoothed/raw aggregatin
character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: aggr_ord ! Ordering for aggregation
character(len=16) :: aggr_filter ! Use filtering?
character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing
integer(psb_ipk_) :: csize ! aggregation size at which to stop.
@ -186,6 +187,8 @@ program mld_d_pde3d
type(precdata) :: prectype
type(psb_d_coo_sparse_mat) :: acoo
! other variables
logical :: dump_prec
character(len=40) :: dump_prefix
integer(psb_ipk_) :: info, i
character(len=20) :: name,ch_err
@ -214,7 +217,8 @@ program mld_d_pde3d
!
! get parameters
!
call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps)
call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,&
&dump_prec,dump_prefix)
!
! allocate and fill in the coefficient matrix, rhs and initial guess
@ -258,6 +262,7 @@ program mld_d_pde3d
call mld_precset(prec,'aggr_kind', prectype%aggrkind,info)
call mld_precset(prec,'aggr_alg', prectype%aggr_alg,info)
call mld_precset(prec,'aggr_ord', prectype%aggr_ord,info)
call mld_precset(prec,'aggr_filter', prectype%aggr_filter, info)
call psb_barrier(ictxt)
t1 = psb_wtime()
@ -380,6 +385,10 @@ program mld_d_pde3d
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize
end if
if (dump_prec) call prec%dump(info,prefix=trim(dump_prefix),&
& ac=.true.,solver=.true.,smoother=.true.,rp=.true.,global_num=.true.)
!
! cleanup storage and exit
!
@ -404,13 +413,17 @@ contains
!
! get iteration parameters from standard input
!
subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps)
subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps,&
& dump_prec,dump_prefix)
integer(psb_ipk_) :: ictxt
type(precdata) :: prectype
character(len=*) :: kmethd, afmt
integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst
integer(psb_ipk_) :: np, iam, info
real(psb_dpk_) :: eps
logical :: dump_prec
character(len=*) :: dump_prefix
character(len=20) :: buffer
call psb_info(ictxt, iam, np)
@ -424,6 +437,8 @@ contains
call read_data(itrace,psb_inp_unit)
call read_data(irst,psb_inp_unit)
call read_data(eps,psb_inp_unit)
call read_data(dump_prec,psb_inp_unit)
call read_data(dump_prefix,psb_inp_unit)
call read_data(prectype%descr,psb_inp_unit) ! verbose description of the prec
call read_data(prectype%prec,psb_inp_unit) ! overall prectype
call read_data(prectype%nlevs,psb_inp_unit) ! Prescribed number of levels
@ -434,6 +449,7 @@ contains
call read_data(prectype%aggrkind,psb_inp_unit) ! smoothed/nonsmoothed/minenergy aggregatin
call read_data(prectype%aggr_alg,psb_inp_unit) ! decoupled or sym. decoupled aggregation
call read_data(prectype%aggr_ord,psb_inp_unit) ! aggregation ordering: natural, node degree
call read_data(prectype%aggr_filter,psb_inp_unit) ! aggregation filtering: filter, no_filter
call read_data(prectype%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec
call read_data(prectype%smthpos,psb_inp_unit) ! side: pre, post, both smoothing
call read_data(prectype%jsweeps,psb_inp_unit) ! Smoother sweeps
@ -462,6 +478,8 @@ contains
call psb_bcast(ictxt,itrace)
call psb_bcast(ictxt,irst)
call psb_bcast(ictxt,eps)
call psb_bcast(ictxt,dump_prec)
call psb_bcast(ictxt,dump_prefix)
call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec
call psb_bcast(ictxt,prectype%prec) ! overall prectype
call psb_bcast(ictxt,prectype%nlevs) ! Prescribed number of levels
@ -472,6 +490,7 @@ contains
call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/nonsmoothed/minenergy aggregatin
call psb_bcast(ictxt,prectype%aggr_alg) ! decoupled or sym. decoupled aggregation
call psb_bcast(ictxt,prectype%aggr_ord) ! aggregation ordering: natural, node degree
call psb_bcast(ictxt,prectype%aggr_filter) ! aggregation filtering: filter, no_filter
call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec
call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing
call psb_bcast(ictxt,prectype%jsweeps) ! Smoother sweeps

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

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

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

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

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

Write Preview
Loading…
Cancel
Save