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

Merge branch 'PolySmooth' into development

Browse Source
l1-and-0-aggr
sfilippone 2 years ago
parent c9605d1b29 c1e8bc0c57
commit 474c6a3634
118 changed files with 8206 additions and 787 deletions
Show Stats Download Patch File Download Diff File

5
amgprec/Makefile
Unescape Escape View File

@ -9,6 +9,7 @@ FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES)
DMODOBJS=amg_d_prec_type.o \
amg_d_inner_mod.o amg_d_ilu_solver.o amg_d_diag_solver.o amg_d_jac_smoother.o amg_d_as_smoother.o \
amg_d_poly_smoother.o amg_d_poly_coeff_mod.o\
amg_d_umf_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o amg_d_id_solver.o\
amg_d_base_solver_mod.o amg_d_base_smoother_mod.o amg_d_onelev_mod.o \
amg_d_gs_solver.o amg_d_mumps_solver.o amg_d_jac_solver.o \
@ -20,7 +21,7 @@ DMODOBJS=amg_d_prec_type.o \
SMODOBJS=amg_s_prec_type.o amg_s_ilu_fact_mod.o \
amg_s_inner_mod.o amg_s_ilu_solver.o amg_s_diag_solver.o amg_s_jac_smoother.o amg_s_as_smoother.o \
amg_s_slu_solver.o amg_s_id_solver.o\
amg_s_poly_smoother.o amg_s_slu_solver.o amg_s_id_solver.o\
amg_s_base_solver_mod.o amg_s_base_smoother_mod.o amg_s_onelev_mod.o \
amg_s_gs_solver.o amg_s_mumps_solver.o amg_s_jac_solver.o \
amg_s_base_aggregator_mod.o \
@ -164,6 +165,8 @@ amg_d_jac_smoother.o: amg_d_diag_solver.o
amg_dprecinit.o amg_dprecset.o: amg_d_diag_solver.o amg_d_ilu_solver.o \
amg_d_umf_solver.o amg_d_as_smoother.o amg_d_jac_smoother.o \
amg_d_id_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o
amg_d_poly_smoother.o: amg_d_base_smoother_mod.o amg_d_poly_coeff_mod.o
amg_s_poly_smoother.o: amg_s_base_smoother_mod.o amg_d_poly_coeff_mod.o
amg_s_mumps_solver.o amg_s_gs_solver.o amg_s_id_solver.o amg_s_slu_solver.o \
amg_s_diag_solver.o amg_s_ilu_solver.o amg_s_jac_solver.o: amg_s_base_solver_mod.o amg_s_prec_type.o

55
amgprec/amg_base_prec_type.F90
Unescape Escape View File

@ -215,7 +215,8 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_fbgs_ = 6
integer(psb_ipk_), parameter :: amg_l1_gs_ = 7
integer(psb_ipk_), parameter :: amg_l1_fbgs_ = 8
integer(psb_ipk_), parameter :: amg_max_prec_ = 8
integer(psb_ipk_), parameter :: amg_poly_ = 9
integer(psb_ipk_), parameter :: amg_max_prec_ = 9
!
! Constants for pre/post signaling. Now only used internally
!
@ -233,9 +234,9 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_diag_scale_ = amg_slv_delta_+1
integer(psb_ipk_), parameter :: amg_l1_diag_scale_ = amg_slv_delta_+2
integer(psb_ipk_), parameter :: amg_gs_ = amg_slv_delta_+3
! !$ integer(psb_ipk_), parameter :: amg_ilu_n_ = amg_slv_delta_+4
! !$ integer(psb_ipk_), parameter :: amg_milu_n_ = amg_slv_delta_+5
! !$ integer(psb_ipk_), parameter :: amg_ilu_t_ = amg_slv_delta_+6
integer(psb_ipk_), parameter :: amg_ilu_n_ = amg_slv_delta_+4
integer(psb_ipk_), parameter :: amg_milu_n_ = amg_slv_delta_+5
integer(psb_ipk_), parameter :: amg_ilu_t_ = amg_slv_delta_+6
integer(psb_ipk_), parameter :: amg_slu_ = amg_slv_delta_+7
integer(psb_ipk_), parameter :: amg_umf_ = amg_slv_delta_+8
integer(psb_ipk_), parameter :: amg_sludist_ = amg_slv_delta_+9
@ -319,6 +320,16 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_distr_mat_ = 0
integer(psb_ipk_), parameter :: amg_repl_mat_ = 1
integer(psb_ipk_), parameter :: amg_max_coarse_mat_ = amg_repl_mat_
!
! Legal values for entry: amg_poly_variant_
!
integer(psb_ipk_), parameter :: amg_poly_lottes_ = 0
integer(psb_ipk_), parameter :: amg_poly_lottes_beta_ = 1
integer(psb_ipk_), parameter :: amg_poly_new_ = 2
integer(psb_ipk_), parameter :: amg_poly_dbg_ = 8
integer(psb_ipk_), parameter :: amg_poly_rho_est_power_ = 0
!
! Legal values for entry: amg_prec_status_
!
@ -390,12 +401,12 @@ module amg_base_prec_type
& ml_names(0:7)=(/'none ','additive ',&
& 'multiplicative', 'VCycle ','WCycle ',&
& 'KCycle ','KCycleSym ','new ML '/)
character(len=15), parameter :: &
character(len=16), parameter :: &
& amg_fact_names(0:amg_max_sub_solve_)=(/&
& 'none ','Jacobi ',&
& 'L1-Jacobi ','none ','none ',&
& 'none ','none ','L1-GS ',&
& 'L1-FBGS ','none ','Point Jacobi ',&
& 'L1-FBGS ','Polynomial ','none ','Point Jacobi ',&
& 'L1-Jacobi ','Gauss-Seidel ','ILU(n) ',&
& 'MILU(n) ','ILU(t,n) ',&
& 'SuperLU ','UMFPACK LU ',&
@ -457,12 +468,12 @@ contains
character(len=*), parameter :: name='amg_stringval'
! Local variable
integer :: index_tab
character(len=15) ::string2
character(len=128) ::string2
index_tab=index(string,char(9))
if (index_tab.NE.0) then
string2=string(1:index_tab-1)
string2=string(1:index_tab-1)
else
string2=string
string2=string
endif
select case(psb_toupper(trim(string2)))
case('NONE')
@ -482,11 +493,11 @@ contains
case('BGS','BWGS')
val = amg_bwgs_
case('ILU')
val = psb_ilu_n_
val = amg_ilu_n_
case('MILU')
val = psb_milu_n_
val = amg_milu_n_
case('ILUT')
val = psb_ilu_t_
val = amg_ilu_t_
case('MUMPS')
val = amg_mumps_
case('UMF')
@ -557,6 +568,18 @@ contains
val = amg_krm_
case('AS')
val = amg_as_
case('POLY')
val = amg_poly_
case('POLY_LOTTES')
val = amg_poly_lottes_
case('POLY_LOTTES_BETA')
val = amg_poly_lottes_beta_
case('POLY_NEW')
val = amg_poly_new_
case('POLY_DBG')
val = amg_poly_dbg_
case('POLY_RHO_EST_POWER')
val = amg_poly_rho_est_power_
case('A_NORMI')
val = amg_max_norm_
case('USER_CHOICE')
@ -667,10 +690,10 @@ contains
& ml_names(pm%ml_cycle)
select case (pm%ml_cycle)
case (amg_add_ml_)
write(iout,*) ' Number of smoother sweeps : ',&
write(iout,*) ' Number of smoother sweeps/degree : ',&
& pm%sweeps_pre
case (amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_, amg_kcycle_ml_, amg_kcyclesym_ml_)
write(iout,*) ' Number of smoother sweeps : pre: ',&
write(iout,*) ' Number of smoother sweeps/degree : pre: ',&
& pm%sweeps_pre ,' post: ', pm%sweeps_post
end select
@ -1036,8 +1059,8 @@ contains
integer(psb_ipk_), intent(in) :: ip
logical :: is_legal_ilu_fact
is_legal_ilu_fact = ((ip==psb_ilu_n_).or.&
& (ip==psb_milu_n_).or.(ip==psb_ilu_t_))
is_legal_ilu_fact = ((ip==amg_ilu_n_).or.&
& (ip==amg_milu_n_).or.(ip==amg_ilu_t_))
return
end function is_legal_ilu_fact
function is_legal_d_omega(ip)

14
amgprec/amg_c_ilu_solver.f90
Unescape Escape View File

@ -234,7 +234,7 @@ contains
! Arguments
class(amg_c_ilu_solver_type), intent(inout) :: sv
sv%fact_type = psb_ilu_n_
sv%fact_type = amg_ilu_n_
sv%fill_in = 0
sv%thresh = szero
@ -255,13 +255,13 @@ contains
info = psb_success_
call amg_check_def(sv%fact_type,&
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(psb_ilu_n_,psb_milu_n_)
case(amg_ilu_n_,amg_milu_n_)
call amg_check_def(sv%fill_in,&
& 'Level',izero,is_int_non_negative)
case(psb_ilu_t_)
case(amg_ilu_t_)
call amg_check_def(sv%thresh,&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
@ -439,9 +439,9 @@ contains
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
& amg_fact_names(sv%fact_type)
select case(sv%fact_type)
case(psb_ilu_n_,psb_milu_n_)
case(amg_ilu_n_,amg_milu_n_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
case(psb_ilu_t_)
case(amg_ilu_t_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
end select
@ -496,7 +496,7 @@ contains
implicit none
integer(psb_ipk_) :: val
val = psb_ilu_n_
val = amg_ilu_n_
end function c_ilu_solver_get_id
function c_ilu_solver_get_wrksize() result(val)

18
amgprec/amg_c_onelev_mod.f90
Unescape Escape View File

@ -187,6 +187,7 @@ module amg_c_onelev_mod
procedure, pass(lv) :: clone => c_base_onelev_clone
procedure, pass(lv) :: cnv => amg_c_base_onelev_cnv
procedure, pass(lv) :: descr => amg_c_base_onelev_descr
procedure, pass(lv) :: memory_use => amg_c_base_onelev_memory_use
procedure, pass(lv) :: default => c_base_onelev_default
procedure, pass(lv) :: free => amg_c_base_onelev_free
procedure, pass(lv) :: free_smoothers => amg_c_base_onelev_free_smoothers
@ -273,6 +274,23 @@ module amg_c_onelev_mod
end subroutine amg_c_base_onelev_descr
end interface
interface
subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
Implicit None
! Arguments
class(amg_c_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_c_base_onelev_memory_use
end interface
interface
subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
import :: amg_c_onelev_type, psb_c_base_vect_type, psb_spk_, &

17
amgprec/amg_c_prec_type.f90
Unescape Escape View File

@ -139,6 +139,7 @@ module amg_c_prec_type
procedure, pass(prec) :: smoothers_build => amg_c_smoothers_bld
procedure, pass(prec) :: smoothers_free => amg_c_smoothers_free
procedure, pass(prec) :: descr => amg_cfile_prec_descr
procedure, pass(prec) :: memory_use => amg_cfile_prec_memory_use
end type amg_cprec_type
private :: amg_c_dump, amg_c_get_compl, amg_c_cmp_compl,&
@ -170,6 +171,22 @@ module amg_c_prec_type
end subroutine amg_cfile_prec_descr
end interface
interface amg_memory_use
subroutine amg_cfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
import :: amg_cprec_type, psb_ipk_
implicit none
! Arguments
class(amg_cprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_cfile_prec_memory_use
end interface
interface amg_sizeof
module procedure amg_cprec_sizeof
end interface

14
amgprec/amg_d_ilu_solver.f90
Unescape Escape View File

@ -234,7 +234,7 @@ contains
! Arguments
class(amg_d_ilu_solver_type), intent(inout) :: sv
sv%fact_type = psb_ilu_n_
sv%fact_type = amg_ilu_n_
sv%fill_in = 0
sv%thresh = dzero
@ -255,13 +255,13 @@ contains
info = psb_success_
call amg_check_def(sv%fact_type,&
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(psb_ilu_n_,psb_milu_n_)
case(amg_ilu_n_,amg_milu_n_)
call amg_check_def(sv%fill_in,&
& 'Level',izero,is_int_non_negative)
case(psb_ilu_t_)
case(amg_ilu_t_)
call amg_check_def(sv%thresh,&
& 'Eps',dzero,is_legal_d_fact_thrs)
end select
@ -439,9 +439,9 @@ contains
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
& amg_fact_names(sv%fact_type)
select case(sv%fact_type)
case(psb_ilu_n_,psb_milu_n_)
case(amg_ilu_n_,amg_milu_n_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
case(psb_ilu_t_)
case(amg_ilu_t_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
end select
@ -496,7 +496,7 @@ contains
implicit none
integer(psb_ipk_) :: val
val = psb_ilu_n_
val = amg_ilu_n_
end function d_ilu_solver_get_id
function d_ilu_solver_get_wrksize() result(val)

18
amgprec/amg_d_onelev_mod.f90
Unescape Escape View File

@ -188,6 +188,7 @@ module amg_d_onelev_mod
procedure, pass(lv) :: clone => d_base_onelev_clone
procedure, pass(lv) :: cnv => amg_d_base_onelev_cnv
procedure, pass(lv) :: descr => amg_d_base_onelev_descr
procedure, pass(lv) :: memory_use => amg_d_base_onelev_memory_use
procedure, pass(lv) :: default => d_base_onelev_default
procedure, pass(lv) :: free => amg_d_base_onelev_free
procedure, pass(lv) :: free_smoothers => amg_d_base_onelev_free_smoothers
@ -274,6 +275,23 @@ module amg_d_onelev_mod
end subroutine amg_d_base_onelev_descr
end interface
interface
subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
Implicit None
! Arguments
class(amg_d_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_d_base_onelev_memory_use
end interface
interface
subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
import :: amg_d_onelev_type, psb_d_base_vect_type, psb_dpk_, &

548
amgprec/amg_d_poly_coeff_mod.f90
Unescape Escape View File

@ -0,0 +1,548 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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: amg_d_poly_smoother_mod.f90
!
! Module: amg_d_poly_smoother_mod
!
! This module defines:
! the amg_d_poly_smoother_type data structure containing the
! smoother for a Jacobi/block Jacobi smoother.
! The smoother stores in ND the block off-diagonal matrix.
! One special case is treated separately, when the solver is DIAG or L1-DIAG
! then the ND is the entire off-diagonal part of the matrix (including the
! main diagonal block), so that it becomes possible to implement
! a pure Jacobi or L1-Jacobi global solver.
!
module amg_d_poly_coeff_mod
use psb_base_mod
real(psb_dpk_), parameter :: amg_d_poly_a_vect(30) = [ &
& 0.3333333333333333_psb_dpk_, &
& 0.1805359927403007_psb_dpk_, &
& 0.1159278464862213_psb_dpk_, &
& 0.0820780659590383_psb_dpk_, &
& 0.0618496002413377_psb_dpk_, &
& 0.0486605823426062_psb_dpk_, &
& 0.0395132986024057_psb_dpk_, &
& 0.0328701017544880_psb_dpk_, &
& 0.0278702862721800_psb_dpk_, &
& 0.0239987409600620_psb_dpk_, &
& 0.0209304400432259_psb_dpk_, &
& 0.0184513099045066_psb_dpk_, &
& 0.0164152586042591_psb_dpk_, &
& 0.0147195638076874_psb_dpk_, &
& 0.0132901324757843_psb_dpk_, &
& 0.0120723317737698_psb_dpk_, &
& 0.0110250964606384_psb_dpk_, &
& 0.0101170330064859_psb_dpk_, &
& 0.0093237789039835_psb_dpk_, &
& 0.0086261728849515_psb_dpk_, &
& 0.0080089618703679_psb_dpk_, &
& 0.0074598709610601_psb_dpk_, &
& 0.0069689238144320_psb_dpk_, &
& 0.0065279387776372_psb_dpk_, &
& 0.0061301503808627_psb_dpk_, &
& 0.0057699215598864_psb_dpk_, &
& 0.0054425224281914_psb_dpk_, &
& 0.0051439584672521_psb_dpk_, &
& 0.0048708358327268_psb_dpk_, &
& 0.0046202548314912_psb_dpk_ ];
real(psb_dpk_), parameter :: amg_d_poly_beta_vect(900) = [ &
& 1.1250000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0238728757031315_psb_dpk_, 1.2640890537108553_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0084254478202830_psb_dpk_, 1.0886783920873087_psb_dpk_, &
& 1.3375312590961856_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0039131042728535_psb_dpk_, 1.0403581118859304_psb_dpk_, &
& 1.1486349854625493_psb_dpk_, 1.3826886924100055_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0021293014616472_psb_dpk_, 1.0217371154926094_psb_dpk_, &
& 1.0787243319260302_psb_dpk_, 1.1981006529266300_psb_dpk_, &
& 1.4132254279168215_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0012851725594023_psb_dpk_, 1.0130429303523338_psb_dpk_, &
& 1.0467821512411335_psb_dpk_, 1.1161648941967548_psb_dpk_, &
& 1.2382902021844453_psb_dpk_, 1.4352429710674484_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0008346439791242_psb_dpk_, 1.0084394943012289_psb_dpk_, &
& 1.0300870776871385_psb_dpk_, 1.0740838409200377_psb_dpk_, &
& 1.1503618670736642_psb_dpk_, 1.2711647404613990_psb_dpk_, &
& 1.4518665864936395_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0005724663119766_psb_dpk_, 1.0057742766241562_psb_dpk_, &
& 1.0205018792294143_psb_dpk_, 1.0501980344456543_psb_dpk_, &
& 1.1011557298494106_psb_dpk_, 1.1808604280685657_psb_dpk_, &
& 1.2983858538257604_psb_dpk_, 1.4648607315109978_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0004096007283281_psb_dpk_, 1.0041243950610661_psb_dpk_, &
& 1.0146021214826659_psb_dpk_, 1.0356111362667175_psb_dpk_, &
& 1.0713997252919425_psb_dpk_, 1.1268827371096291_psb_dpk_, &
& 1.2078521914072933_psb_dpk_, 1.3212193071674674_psb_dpk_, &
& 1.4752964282069962_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0003031222965291_psb_dpk_, 1.0030484066079688_psb_dpk_, &
& 1.0107702271538761_psb_dpk_, 1.0261901159764004_psb_dpk_, &
& 1.0523172493375519_psb_dpk_, 1.0925574320754976_psb_dpk_, &
& 1.1508337666397197_psb_dpk_, 1.2317225087089441_psb_dpk_, &
& 1.3406080202445980_psb_dpk_, 1.4838612440701109_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0002305859520939_psb_dpk_, 1.0023167502402850_psb_dpk_, &
& 1.0081724539630488_psb_dpk_, 1.0198298656634219_psb_dpk_, &
& 1.0395021023532465_psb_dpk_, 1.0696504270054137_psb_dpk_, &
& 1.1130575429574259_psb_dpk_, 1.1729087627556418_psb_dpk_, &
& 1.2528830057679230_psb_dpk_, 1.3572557991951903_psb_dpk_, &
& 1.4910167256413891_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0001794720082837_psb_dpk_, 1.0018018913961957_psb_dpk_, &
& 1.0063486190730762_psb_dpk_, 1.0153786456630600_psb_dpk_, &
& 1.0305694283076039_psb_dpk_, 1.0537601969394355_psb_dpk_, &
& 1.0869986259207296_psb_dpk_, 1.1325918309791341_psb_dpk_, &
& 1.1931627335817252_psb_dpk_, 1.2717129367511055_psb_dpk_, &
& 1.3716933796979953_psb_dpk_, 1.4970841857556243_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0001424192155957_psb_dpk_, 1.0014290693262966_psb_dpk_, &
& 1.0050302898629815_psb_dpk_, 1.0121691051849540_psb_dpk_, &
& 1.0241487434279255_psb_dpk_, 1.0423815888082042_psb_dpk_, &
& 1.0684200812870084_psb_dpk_, 1.1039901093675994_psb_dpk_, &
& 1.1510274824264566_psb_dpk_, 1.2117181191012512_psb_dpk_, &
& 1.2885426486512805_psb_dpk_, 1.3843261938099158_psb_dpk_, &
& 1.5022941875736890_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0001149053826193_psb_dpk_, 1.0011524637691460_psb_dpk_, &
& 1.0040535733326481_psb_dpk_, 1.0097959057315313_psb_dpk_, &
& 1.0194130047299461_psb_dpk_, 1.0340142503543679_psb_dpk_, &
& 1.0548059960662932_psb_dpk_, 1.0831142030181304_psb_dpk_, &
& 1.1204089166089239_psb_dpk_, 1.1683309565544606_psb_dpk_, &
& 1.2287212228823874_psb_dpk_, 1.3036530570781755_psb_dpk_, &
& 1.3954681405367855_psb_dpk_, 1.5068164620958386_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000940475075257_psb_dpk_, 1.0009429169634352_psb_dpk_, &
& 1.0033144905644482_psb_dpk_, 1.0080029483381612_psb_dpk_, &
& 1.0158423625914039_psb_dpk_, 1.0277208331770495_psb_dpk_, &
& 1.0445953542283146_psb_dpk_, 1.0675076120612534_psb_dpk_, &
& 1.0976009254588965_psb_dpk_, 1.1361385536615733_psb_dpk_, &
& 1.1845236142623621_psb_dpk_, 1.2443208730447588_psb_dpk_, &
& 1.3172806908339272_psb_dpk_, 1.4053654389356023_psb_dpk_, &
& 1.5107787250184523_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000779482817921_psb_dpk_, 1.0007812684725339_psb_dpk_, &
& 1.0027448797440124_psb_dpk_, 1.0066229101701514_psb_dpk_, &
& 1.0130985883697137_psb_dpk_, 1.0228944832933697_psb_dpk_, &
& 1.0367832140998394_psb_dpk_, 1.0555987571989653_psb_dpk_, &
& 1.0802484840556024_psb_dpk_, 1.1117260713149764_psb_dpk_, &
& 1.1511254343107276_psb_dpk_, 1.1996558461497355_psb_dpk_, &
& 1.2586584174494597_psb_dpk_, 1.3296241265666493_psb_dpk_, &
& 1.4142136069557629_psb_dpk_, 1.5142789173034623_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000653242183546_psb_dpk_, 1.0006545722939437_psb_dpk_, &
& 1.0022987777448662_psb_dpk_, 1.0055432691173583_psb_dpk_, &
& 1.0109550075016893_psb_dpk_, 1.0191301541168694_psb_dpk_, &
& 1.0307019481191382_psb_dpk_, 1.0463489778000818_psb_dpk_, &
& 1.0668039321569163_psb_dpk_, 1.0928629244731740_psb_dpk_, &
& 1.1253954850882542_psb_dpk_, 1.1653553270075827_psb_dpk_, &
& 1.2137919954743157_psb_dpk_, 1.2718635211544003_psb_dpk_, &
& 1.3408502062615073_psb_dpk_, 1.4221696838526183_psb_dpk_, &
& 1.5173934027630227_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000552858792859_psb_dpk_, 1.0005538659610900_psb_dpk_, &
& 1.0019444166743086_psb_dpk_, 1.0046864301776393_psb_dpk_, &
& 1.0092557508630260_psb_dpk_, 1.0161502674772371_psb_dpk_, &
& 1.0258958148322650_psb_dpk_, 1.0390523408953256_psb_dpk_, &
& 1.0562203973533295_psb_dpk_, 1.0780480145522537_psb_dpk_, &
& 1.1052380250439366_psb_dpk_, 1.1385559038570177_psb_dpk_, &
& 1.1788381980793483_psb_dpk_, 1.2270016234308427_psb_dpk_, &
& 1.2840529112630572_psb_dpk_, 1.3510994958895055_psb_dpk_, &
& 1.4293611393851839_psb_dpk_, 1.5201825990516680_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000472036358790_psb_dpk_, 1.0004728102642675_psb_dpk_, &
& 1.0016593577469159_psb_dpk_, 1.0039976891368516_psb_dpk_, &
& 1.0078911941833455_psb_dpk_, 1.0137601583069535_psb_dpk_, &
& 1.0220462561721002_psb_dpk_, 1.0332172281153209_psb_dpk_, &
& 1.0477717791157513_psb_dpk_, 1.0662447417325256_psb_dpk_, &
& 1.0892125464929936_psb_dpk_, 1.1172990456131733_psb_dpk_, &
& 1.1511817386833911_psb_dpk_, 1.1915984520803475_psb_dpk_, &
& 1.2393545273929878_psb_dpk_, 1.2953305781018039_psb_dpk_, &
& 1.3604908781568688_psb_dpk_, 1.4358924509939206_psb_dpk_, &
& 1.5226949329440265_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000406232569254_psb_dpk_, 1.0004068351374691_psb_dpk_, &
& 1.0014274431564170_psb_dpk_, 1.0034377175807407_psb_dpk_, &
& 1.0067826854070978_psb_dpk_, 1.0118204999571436_psb_dpk_, &
& 1.0189259121271075_psb_dpk_, 1.0284938700470616_psb_dpk_, &
& 1.0409432748132981_psb_dpk_, 1.0567209210598594_psb_dpk_, &
& 1.0763056524407055_psb_dpk_, 1.1002127636100871_psb_dpk_, &
& 1.1289986820268283_psb_dpk_, 1.1632659648787138_psb_dpk_, &
& 1.2036686486408621_psb_dpk_, 1.2509179912601627_psb_dpk_, &
& 1.3057886497146727_psb_dpk_, 1.3691253387497200_psb_dpk_, &
& 1.4418500199624611_psb_dpk_, 1.5249696741164267_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000352114440929_psb_dpk_, 1.0003525892395289_psb_dpk_, &
& 1.0012368357172980_psb_dpk_, 1.0029777430511673_psb_dpk_, &
& 1.0058727830027672_psb_dpk_, 1.0102297507781717_psb_dpk_, &
& 1.0163694815733537_psb_dpk_, 1.0246286588536329_psb_dpk_, &
& 1.0353627340015590_psb_dpk_, 1.0489489776835172_psb_dpk_, &
& 1.0657896841306789_psb_dpk_, 1.0863155505114006_psb_dpk_, &
& 1.1109892546943501_psb_dpk_, 1.1403092559728156_psb_dpk_, &
& 1.1748138447471401_psb_dpk_, 1.2150854687543668_psb_dpk_, &
& 1.2617553651999671_psb_dpk_, 1.3155085300984379_psb_dpk_, &
& 1.3770890582780710_psb_dpk_, 1.4473058898645985_psb_dpk_, &
& 1.5270390016420912_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000307198714835_psb_dpk_, 1.0003075769178242_psb_dpk_, &
& 1.0010787281022711_psb_dpk_, 1.0025963829693492_psb_dpk_, &
& 1.0051188625231162_psb_dpk_, 1.0089126974249720_psb_dpk_, &
& 1.0142547789760521_psb_dpk_, 1.0214345766593154_psb_dpk_, &
& 1.0307564364069204_psb_dpk_, 1.0425419742322541_psb_dpk_, &
& 1.0571325804249445_psb_dpk_, 1.0748920501551993_psb_dpk_, &
& 1.0962093570737961_psb_dpk_, 1.1215015873309027_psb_dpk_, &
& 1.1512170523743910_psb_dpk_, 1.1858385999327761_psb_dpk_, &
& 1.2258871437439198_psb_dpk_, 1.2719254338660289_psb_dpk_, &
& 1.3245620908078453_psb_dpk_, 1.3844559282498121_psb_dpk_, &
& 1.4523205908039656_psb_dpk_, 1.5289295350887884_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000269609460124_psb_dpk_, 1.0002699137181752_psb_dpk_, &
& 1.0009464748475532_psb_dpk_, 1.0022775198638552_psb_dpk_, &
& 1.0044888368184179_psb_dpk_, 1.0078128087804721_psb_dpk_, &
& 1.0124901352066715_psb_dpk_, 1.0187716022931539_psb_dpk_, &
& 1.0269199126829005_psb_dpk_, 1.0372115852204526_psb_dpk_, &
& 1.0499389358225151_psb_dpk_, 1.0654121509688057_psb_dpk_, &
& 1.0839614658147161_psb_dpk_, 1.1059394594887115_psb_dpk_, &
& 1.1317234807654135_psb_dpk_, 1.1617182180038959_psb_dpk_, &
& 1.1963584280123116_psb_dpk_, 1.2361118393501820_psb_dpk_, &
& 1.2814822465106404_psb_dpk_, 1.3330128124440397_psb_dpk_, &
& 1.3912895979940381_psb_dpk_, 1.4569453380258381_psb_dpk_, &
& 1.5306634853375161_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000237911597230_psb_dpk_, 1.0002381585998457_psb_dpk_, &
& 1.0008349974382460_psb_dpk_, 1.0020088476285827_psb_dpk_, &
& 1.0039582343156432_psb_dpk_, 1.0068870298152559_psb_dpk_, &
& 1.0110058445931565_psb_dpk_, 1.0165334547611182_psb_dpk_, &
& 1.0236982737890488_psb_dpk_, 1.0327398763510158_psb_dpk_, &
& 1.0439105824804926_psb_dpk_, 1.0574771105088172_psb_dpk_, &
& 1.0737223076000839_psb_dpk_, 1.0929469670793606_psb_dpk_, &
& 1.1154717421787756_psb_dpk_, 1.1416391663018148_psb_dpk_, &
& 1.1718157904303341_psb_dpk_, 1.2063944488757254_psb_dpk_, &
& 1.2457966652063013_psb_dpk_, 1.2904752108716941_psb_dpk_, &
& 1.3409168297942540_psb_dpk_, 1.3976451430108305_psb_dpk_, &
& 1.4612237483301715_psb_dpk_, 1.5322595309246121_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000210994601235_psb_dpk_, 1.0002111968041199_psb_dpk_, &
& 1.0007403694573151_psb_dpk_, 1.0017808593384865_psb_dpk_, &
& 1.0035081686576977_psb_dpk_, 1.0061021720448531_psb_dpk_, &
& 1.0097482505685551_psb_dpk_, 1.0146384533048582_psb_dpk_, &
& 1.0209726922414943_psb_dpk_, 1.0289599764553270_psb_dpk_, &
& 1.0388196916802268_psb_dpk_, 1.0507829315895938_psb_dpk_, &
& 1.0650938873538003_psb_dpk_, 1.0820113022982043_psb_dpk_, &
& 1.1018099987843295_psb_dpk_, 1.1247824847650900_psb_dpk_, &
& 1.1512406478277994_psb_dpk_, 1.1815175449359154_psb_dpk_, &
& 1.2159692965153148_psb_dpk_, 1.2549770940040335_psb_dpk_, &
& 1.2989493304988182_psb_dpk_, 1.3483238646890843_psb_dpk_, &
& 1.4035704288718982_psb_dpk_, 1.4651931924923849_psb_dpk_, &
& 1.5337334933563860_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000187989989242_psb_dpk_, 1.0001881567984481_psb_dpk_, &
& 1.0006595227084085_psb_dpk_, 1.0015861311895899_psb_dpk_, &
& 1.0031239047778964_psb_dpk_, 1.0054323694760092_psb_dpk_, &
& 1.0086755868504005_psb_dpk_, 1.0130231071421940_psb_dpk_, &
& 1.0186509477893992_psb_dpk_, 1.0257426018654052_psb_dpk_, &
& 1.0344900810652515_psb_dpk_, 1.0450949980170887_psb_dpk_, &
& 1.0577696928624343_psb_dpk_, 1.0727384092356933_psb_dpk_, &
& 1.0902385249817814_psb_dpk_, 1.1105218431816117_psb_dpk_, &
& 1.1338559493090710_psb_dpk_, 1.1605256406217599_psb_dpk_, &
& 1.1908344341913664_psb_dpk_, 1.2251061603103259_psb_dpk_, &
& 1.2636866483695495_psb_dpk_, 1.3069455126904677_psb_dpk_, &
& 1.3552780462128098_psb_dpk_, 1.4091072303921326_psb_dpk_, &
& 1.4688858701459975_psb_dpk_, 1.5350988632115488_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000168211938973_psb_dpk_, 1.0001683505351420_psb_dpk_, &
& 1.0005900360142315_psb_dpk_, 1.0014188084960041_psb_dpk_, &
& 1.0027938311393803_psb_dpk_, 1.0048572584314193_psb_dpk_, &
& 1.0077550080990554_psb_dpk_, 1.0116375492127350_psb_dpk_, &
& 1.0166607098595459_psb_dpk_, 1.0229865078405374_psb_dpk_, &
& 1.0307840079371537_psb_dpk_, 1.0402302093961155_psb_dpk_, &
& 1.0515109674005423_psb_dpk_, 1.0648219524284319_psb_dpk_, &
& 1.0803696515480321_psb_dpk_, 1.0983724158638981_psb_dpk_, &
& 1.1190615585080472_psb_dpk_, 1.1426825077681895_psb_dpk_, &
& 1.1694960201606786_psb_dpk_, 1.1997794584895700_psb_dpk_, &
& 1.2338281401870808_psb_dpk_, 1.2719567615042522_psb_dpk_, &
& 1.3145009034164739_psb_dpk_, 1.3618186254259919_psb_dpk_, &
& 1.4142921537855777_psb_dpk_, 1.4723296710339275_psb_dpk_, &
& 1.5363672141264497_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000151113991291_psb_dpk_, 1.0001512299115287_psb_dpk_, &
& 1.0005299814085029_psb_dpk_, 1.0012742317597600_psb_dpk_, &
& 1.0025087130476142_psb_dpk_, 1.0043606572645858_psb_dpk_, &
& 1.0069604400315522_psb_dpk_, 1.0104422369100252_psb_dpk_, &
& 1.0149446949285030_psb_dpk_, 1.0206116219981500_psb_dpk_, &
& 1.0275926969588451_psb_dpk_, 1.0360442030716124_psb_dpk_, &
& 1.0461297878595799_psb_dpk_, 1.0580212522952626_psb_dpk_, &
& 1.0718993724396861_psb_dpk_, 1.0879547567564958_psb_dpk_, &
& 1.1063887424550545_psb_dpk_, 1.1274143343577541_psb_dpk_, &
& 1.1512571899424711_psb_dpk_, 1.1781566543781672_psb_dpk_, &
& 1.2083668495540898_psb_dpk_, 1.2421578212983135_psb_dpk_, &
& 1.2798167491932815_psb_dpk_, 1.3216492236219661_psb_dpk_, &
& 1.3679805949228399_psb_dpk_, 1.4191573997915068_psb_dpk_, &
& 1.4755488703473389_psb_dpk_, 1.5375485315807513_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000136257096588_psb_dpk_, 1.0001363546506836_psb_dpk_, &
& 1.0004778107488095_psb_dpk_, 1.0011486612681773_psb_dpk_, &
& 1.0022611433613271_psb_dpk_, 1.0039295964948667_psb_dpk_, &
& 1.0062710027404669_psb_dpk_, 1.0094055369479136_psb_dpk_, &
& 1.0134571288503909_psb_dpk_, 1.0185540391932908_psb_dpk_, &
& 1.0248294520252528_psb_dpk_, 1.0324220853457433_psb_dpk_, &
& 1.0414768223656390_psb_dpk_, 1.0521453657079123_psb_dpk_, &
& 1.0645869169533493_psb_dpk_, 1.0789688840227822_psb_dpk_, &
& 1.0954676189818162_psb_dpk_, 1.1142691889576817_psb_dpk_, &
& 1.1355701829701565_psb_dpk_, 1.1595785576006521_psb_dpk_, &
& 1.1865145245551894_psb_dpk_, 1.2166114833191515_psb_dpk_, &
& 1.2501170022543431_psb_dpk_, 1.2872938516530203_psb_dpk_, &
& 1.3284210924391027_psb_dpk_, 1.3737952243949607_psb_dpk_, &
& 1.4237313979931023_psb_dpk_, 1.4785646941265451_psb_dpk_, &
& 1.5386514762605854_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000123285767939_psb_dpk_, 1.0001233683396147_psb_dpk_, &
& 1.0004322711781202_psb_dpk_, 1.0010390719329101_psb_dpk_, &
& 1.0020451337350940_psb_dpk_, 1.0035535979966428_psb_dpk_, &
& 1.0056698406248343_psb_dpk_, 1.0085019360540697_psb_dpk_, &
& 1.0121611307132341_psb_dpk_, 1.0167623275769953_psb_dpk_, &
& 1.0224245834847208_psb_dpk_, 1.0292716209515502_psb_dpk_, &
& 1.0374323562422998_psb_dpk_, 1.0470414455308106_psb_dpk_, &
& 1.0582398510249318_psb_dpk_, 1.0711754290010183_psb_dpk_, &
& 1.0860035417614331_psb_dpk_, 1.1028876956049132_psb_dpk_, &
& 1.1220002069820316_psb_dpk_, 1.1435228990979547_psb_dpk_, &
& 1.1676478313209715_psb_dpk_, 1.1945780638597872_psb_dpk_, &
& 1.2245284602839432_psb_dpk_, 1.2577265305821996_psb_dpk_, &
& 1.2944133175813315_psb_dpk_, 1.3348443296857557_psb_dpk_, &
& 1.3792905230439911_psb_dpk_, 1.4280393364047606_psb_dpk_, &
& 1.4813957820911738_psb_dpk_, 1.5396835966986973_psb_dpk_ ]
!!$ [1.1250000000000000_psb_dpk_, 0.0_psb_dpk_, 0.0_psb_dpk__psb_dpk_,,&
!!$ & 1.0238728757031315_psb_dpk_, 1.2640890537108553_psb_dpk_, 0.0_psb_dpk_,&
!!$ & 1.0084254478202830_psb_dpk_, 1.0886783920873087_psb_dpk_, 1.3375312590961856_psb_dpk_]
real(psb_dpk_), parameter :: amg_d_poly_beta_mat(30,30)=reshape(amg_d_poly_beta_vect,[30,30])
end module amg_d_poly_coeff_mod

374
amgprec/amg_d_poly_smoother.f90
Unescape Escape View File

@ -0,0 +1,374 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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: amg_d_poly_smoother_mod.f90
!
! Module: amg_d_poly_smoother_mod
!
! This module defines:
! the amg_d_poly_smoother_type data structure containing the
! smoother for a Jacobi/block Jacobi smoother.
! The smoother stores in ND the block off-diagonal matrix.
! One special case is treated separately, when the solver is DIAG or L1-DIAG
! then the ND is the entire off-diagonal part of the matrix (including the
! main diagonal block), so that it becomes possible to implement
! a pure Jacobi or L1-Jacobi global solver.
!
module amg_d_poly_smoother
use amg_d_base_smoother_mod
use amg_d_poly_coeff_mod
type, extends(amg_d_base_smoother_type) :: amg_d_poly_smoother_type
! The local solver component is inherited from the
! parent type.
! class(amg_d_base_solver_type), allocatable :: sv
!
integer(psb_ipk_) :: pdegree, variant
integer(psb_ipk_) :: rho_estimate=amg_poly_rho_est_power_
integer(psb_ipk_) :: rho_estimate_iterations=10
type(psb_dspmat_type), pointer :: pa => null()
real(psb_dpk_), allocatable :: poly_beta(:)
real(psb_dpk_) :: cf_a = dzero
real(psb_dpk_) :: rho_ba = -done
contains
procedure, pass(sm) :: apply_v => amg_d_poly_smoother_apply_vect
!!$ procedure, pass(sm) :: apply_a => amg_d_poly_smoother_apply
procedure, pass(sm) :: dump => amg_d_poly_smoother_dmp
procedure, pass(sm) :: build => amg_d_poly_smoother_bld
procedure, pass(sm) :: cnv => amg_d_poly_smoother_cnv
procedure, pass(sm) :: clone => amg_d_poly_smoother_clone
procedure, pass(sm) :: clone_settings => amg_d_poly_smoother_clone_settings
procedure, pass(sm) :: clear_data => amg_d_poly_smoother_clear_data
procedure, pass(sm) :: free => d_poly_smoother_free
procedure, pass(sm) :: cseti => amg_d_poly_smoother_cseti
procedure, pass(sm) :: csetc => amg_d_poly_smoother_csetc
procedure, pass(sm) :: csetr => amg_d_poly_smoother_csetr
procedure, pass(sm) :: descr => amg_d_poly_smoother_descr
procedure, pass(sm) :: sizeof => d_poly_smoother_sizeof
procedure, pass(sm) :: default => d_poly_smoother_default
procedure, pass(sm) :: get_nzeros => d_poly_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => d_poly_smoother_get_wrksize
procedure, nopass :: get_fmt => d_poly_smoother_get_fmt
procedure, nopass :: get_id => d_poly_smoother_get_id
end type amg_d_poly_smoother_type
private :: d_poly_smoother_free, &
& d_poly_smoother_sizeof, d_poly_smoother_get_nzeros, &
& d_poly_smoother_get_fmt, d_poly_smoother_get_id, &
& d_poly_smoother_get_wrksize
interface
subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,wv,info,init,initu)
import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_
type(psb_desc_type), intent(in) :: desc_data
class(amg_d_poly_smoother_type), intent(inout) :: sm
type(psb_d_vect_type),intent(inout) :: x
type(psb_d_vect_type),intent(inout) :: y
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
end subroutine amg_d_poly_smoother_apply_vect
end interface
!!$ interface
!!$ subroutine amg_d_poly_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
!!$ & sweeps,work,info,init,initu)
!!$ import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
!!$ & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, &
!!$ & psb_ipk_
!!$ type(psb_desc_type), intent(in) :: desc_data
!!$ class(amg_d_poly_smoother_type), intent(inout) :: sm
!!$ real(psb_dpk_),intent(inout) :: x(:)
!!$ real(psb_dpk_),intent(inout) :: y(:)
!!$ real(psb_dpk_),intent(in) :: alpha,beta
!!$ character(len=1),intent(in) :: trans
!!$ integer(psb_ipk_), intent(in) :: sweeps
!!$ real(psb_dpk_),target, intent(inout) :: work(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ character, intent(in), optional :: init
!!$ real(psb_dpk_),intent(inout), optional :: initu(:)
!!$ end subroutine amg_d_poly_smoother_apply
!!$ end interface
!!$
interface
subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_d_poly_smoother_bld
end interface
interface
subroutine amg_d_poly_smoother_cnv(sm,info,amold,vmold,imold)
import :: amg_d_poly_smoother_type, psb_dpk_, &
& psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_d_poly_smoother_cnv
end interface
interface
subroutine amg_d_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, &
& psb_ipk_
implicit none
class(amg_d_poly_smoother_type), intent(in) :: sm
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: level
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver, global_num
end subroutine amg_d_poly_smoother_dmp
end interface
interface
subroutine amg_d_poly_smoother_clone(sm,smout,info)
import :: amg_d_poly_smoother_type, psb_dpk_, &
& amg_d_base_smoother_type, psb_ipk_
class(amg_d_poly_smoother_type), intent(inout) :: sm
class(amg_d_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_poly_smoother_clone
end interface
interface
subroutine amg_d_poly_smoother_clone_settings(sm,smout,info)
import :: amg_d_poly_smoother_type, psb_dpk_, &
& amg_d_base_smoother_type, psb_ipk_
class(amg_d_poly_smoother_type), intent(inout) :: sm
class(amg_d_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_poly_smoother_clone_settings
end interface
interface
subroutine amg_d_poly_smoother_clear_data(sm,info)
import :: amg_d_poly_smoother_type, psb_dpk_, &
& amg_d_base_smoother_type, psb_ipk_
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_poly_smoother_clear_data
end interface
interface
subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix)
import :: amg_d_poly_smoother_type, psb_ipk_
class(amg_d_poly_smoother_type), intent(in) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
end subroutine amg_d_poly_smoother_descr
end interface
interface
subroutine amg_d_poly_smoother_cseti(sm,what,val,info,idx)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_d_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_d_poly_smoother_cseti
end interface
interface
subroutine amg_d_poly_smoother_csetc(sm,what,val,info,idx)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_d_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_d_poly_smoother_csetc
end interface
interface
subroutine amg_d_poly_smoother_csetr(sm,what,val,info,idx)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_d_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_d_poly_smoother_csetr
end interface
contains
subroutine d_poly_smoother_free(sm,info)
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_poly_smoother_free'
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(sm%sv)) then
call sm%sv%free(info)
if (info == psb_success_) deallocate(sm%sv,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
end if
if (allocated(sm%poly_beta)) deallocate(sm%poly_beta)
sm%pa => null()
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine d_poly_smoother_free
function d_poly_smoother_sizeof(sm) result(val)
implicit none
! Arguments
class(amg_d_poly_smoother_type), intent(in) :: sm
integer(psb_epk_) :: val
val = psb_sizeof_dp
if (allocated(sm%sv)) val = val + sm%sv%sizeof()
if (allocated(sm%poly_beta)) val = val + psb_sizeof_dp * size(sm%poly_beta)
return
end function d_poly_smoother_sizeof
subroutine d_poly_smoother_default(sm)
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
!
! Default: BJAC with no residual check
!
sm%pdegree = 1
sm%rho_ba = -done
sm%variant = amg_poly_lottes_
sm%rho_estimate = amg_poly_rho_est_power_
sm%rho_estimate_iterations = 20
if (allocated(sm%sv)) then
call sm%sv%default()
end if
return
end subroutine d_poly_smoother_default
function d_poly_smoother_get_nzeros(sm) result(val)
implicit none
! Arguments
class(amg_d_poly_smoother_type), intent(in) :: sm
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = 0
if (allocated(sm%sv)) val = val + sm%sv%get_nzeros()
return
end function d_poly_smoother_get_nzeros
function d_poly_smoother_get_wrksize(sm) result(val)
implicit none
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 4
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function d_poly_smoother_get_wrksize
function d_poly_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Polynomial smoother"
end function d_poly_smoother_get_fmt
function d_poly_smoother_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_poly_
end function d_poly_smoother_get_id
end module amg_d_poly_smoother

17
amgprec/amg_d_prec_type.f90
Unescape Escape View File

@ -139,6 +139,7 @@ module amg_d_prec_type
procedure, pass(prec) :: smoothers_build => amg_d_smoothers_bld
procedure, pass(prec) :: smoothers_free => amg_d_smoothers_free
procedure, pass(prec) :: descr => amg_dfile_prec_descr
procedure, pass(prec) :: memory_use => amg_dfile_prec_memory_use
end type amg_dprec_type
private :: amg_d_dump, amg_d_get_compl, amg_d_cmp_compl,&
@ -170,6 +171,22 @@ module amg_d_prec_type
end subroutine amg_dfile_prec_descr
end interface
interface amg_memory_use
subroutine amg_dfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
import :: amg_dprec_type, psb_ipk_
implicit none
! Arguments
class(amg_dprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_dfile_prec_memory_use
end interface
interface amg_sizeof
module procedure amg_dprec_sizeof
end interface

14
amgprec/amg_s_ilu_solver.f90
Unescape Escape View File

@ -234,7 +234,7 @@ contains
! Arguments
class(amg_s_ilu_solver_type), intent(inout) :: sv
sv%fact_type = psb_ilu_n_
sv%fact_type = amg_ilu_n_
sv%fill_in = 0
sv%thresh = szero
@ -255,13 +255,13 @@ contains
info = psb_success_
call amg_check_def(sv%fact_type,&
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(psb_ilu_n_,psb_milu_n_)
case(amg_ilu_n_,amg_milu_n_)
call amg_check_def(sv%fill_in,&
& 'Level',izero,is_int_non_negative)
case(psb_ilu_t_)
case(amg_ilu_t_)
call amg_check_def(sv%thresh,&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
@ -439,9 +439,9 @@ contains
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
& amg_fact_names(sv%fact_type)
select case(sv%fact_type)
case(psb_ilu_n_,psb_milu_n_)
case(amg_ilu_n_,amg_milu_n_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
case(psb_ilu_t_)
case(amg_ilu_t_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
end select
@ -496,7 +496,7 @@ contains
implicit none
integer(psb_ipk_) :: val
val = psb_ilu_n_
val = amg_ilu_n_
end function s_ilu_solver_get_id
function s_ilu_solver_get_wrksize() result(val)

18
amgprec/amg_s_onelev_mod.f90
Unescape Escape View File

@ -188,6 +188,7 @@ module amg_s_onelev_mod
procedure, pass(lv) :: clone => s_base_onelev_clone
procedure, pass(lv) :: cnv => amg_s_base_onelev_cnv
procedure, pass(lv) :: descr => amg_s_base_onelev_descr
procedure, pass(lv) :: memory_use => amg_s_base_onelev_memory_use
procedure, pass(lv) :: default => s_base_onelev_default
procedure, pass(lv) :: free => amg_s_base_onelev_free
procedure, pass(lv) :: free_smoothers => amg_s_base_onelev_free_smoothers
@ -274,6 +275,23 @@ module amg_s_onelev_mod
end subroutine amg_s_base_onelev_descr
end interface
interface
subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
Implicit None
! Arguments
class(amg_s_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_s_base_onelev_memory_use
end interface
interface
subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
import :: amg_s_onelev_type, psb_s_base_vect_type, psb_spk_, &

374
amgprec/amg_s_poly_smoother.f90
Unescape Escape View File

@ -0,0 +1,374 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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: amg_s_poly_smoother_mod.f90
!
! Module: amg_s_poly_smoother_mod
!
! This module defines:
! the amg_s_poly_smoother_type data structure containing the
! smoother for a Jacobi/block Jacobi smoother.
! The smoother stores in ND the block off-diagonal matrix.
! One special case is treated separately, when the solver is DIAG or L1-DIAG
! then the ND is the entire off-diagonal part of the matrix (including the
! main diagonal block), so that it becomes possible to implement
! a pure Jacobi or L1-Jacobi global solver.
!
module amg_s_poly_smoother
use amg_s_base_smoother_mod
use amg_d_poly_coeff_mod
type, extends(amg_s_base_smoother_type) :: amg_s_poly_smoother_type
! The local solver component is inherited from the
! parent type.
! class(amg_s_base_solver_type), allocatable :: sv
!
integer(psb_ipk_) :: pdegree, variant
integer(psb_ipk_) :: rho_estimate=amg_poly_rho_est_power_
integer(psb_ipk_) :: rho_estimate_iterations=10
type(psb_sspmat_type), pointer :: pa => null()
real(psb_spk_), allocatable :: poly_beta(:)
real(psb_spk_) :: cf_a = szero
real(psb_spk_) :: rho_ba = -sone
contains
procedure, pass(sm) :: apply_v => amg_s_poly_smoother_apply_vect
!!$ procedure, pass(sm) :: apply_a => amg_s_poly_smoother_apply
procedure, pass(sm) :: dump => amg_s_poly_smoother_dmp
procedure, pass(sm) :: build => amg_s_poly_smoother_bld
procedure, pass(sm) :: cnv => amg_s_poly_smoother_cnv
procedure, pass(sm) :: clone => amg_s_poly_smoother_clone
procedure, pass(sm) :: clone_settings => amg_s_poly_smoother_clone_settings
procedure, pass(sm) :: clear_data => amg_s_poly_smoother_clear_data
procedure, pass(sm) :: free => s_poly_smoother_free
procedure, pass(sm) :: cseti => amg_s_poly_smoother_cseti
procedure, pass(sm) :: csetc => amg_s_poly_smoother_csetc
procedure, pass(sm) :: csetr => amg_s_poly_smoother_csetr
procedure, pass(sm) :: descr => amg_s_poly_smoother_descr
procedure, pass(sm) :: sizeof => s_poly_smoother_sizeof
procedure, pass(sm) :: default => s_poly_smoother_default
procedure, pass(sm) :: get_nzeros => s_poly_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => s_poly_smoother_get_wrksize
procedure, nopass :: get_fmt => s_poly_smoother_get_fmt
procedure, nopass :: get_id => s_poly_smoother_get_id
end type amg_s_poly_smoother_type
private :: s_poly_smoother_free, &
& s_poly_smoother_sizeof, s_poly_smoother_get_nzeros, &
& s_poly_smoother_get_fmt, s_poly_smoother_get_id, &
& s_poly_smoother_get_wrksize
interface
subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,wv,info,init,initu)
import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_
type(psb_desc_type), intent(in) :: desc_data
class(amg_s_poly_smoother_type), intent(inout) :: sm
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
end subroutine amg_s_poly_smoother_apply_vect
end interface
!!$ interface
!!$ subroutine amg_s_poly_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
!!$ & sweeps,work,info,init,initu)
!!$ import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
!!$ & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, &
!!$ & psb_ipk_
!!$ type(psb_desc_type), intent(in) :: desc_data
!!$ class(amg_s_poly_smoother_type), intent(inout) :: sm
!!$ real(psb_spk_),intent(inout) :: x(:)
!!$ real(psb_spk_),intent(inout) :: y(:)
!!$ real(psb_spk_),intent(in) :: alpha,beta
!!$ character(len=1),intent(in) :: trans
!!$ integer(psb_ipk_), intent(in) :: sweeps
!!$ real(psb_spk_),target, intent(inout) :: work(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ character, intent(in), optional :: init
!!$ real(psb_spk_),intent(inout), optional :: initu(:)
!!$ end subroutine amg_s_poly_smoother_apply
!!$ end interface
!!$
interface
subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_s_poly_smoother_type), intent(inout) :: sm
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
end subroutine amg_s_poly_smoother_bld
end interface
interface
subroutine amg_s_poly_smoother_cnv(sm,info,amold,vmold,imold)
import :: amg_s_poly_smoother_type, psb_spk_, &
& psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
class(amg_s_poly_smoother_type), intent(inout) :: sm
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
end subroutine amg_s_poly_smoother_cnv
end interface
interface
subroutine amg_s_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, &
& psb_ipk_
implicit none
class(amg_s_poly_smoother_type), intent(in) :: sm
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: level
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver, global_num
end subroutine amg_s_poly_smoother_dmp
end interface
interface
subroutine amg_s_poly_smoother_clone(sm,smout,info)
import :: amg_s_poly_smoother_type, psb_spk_, &
& amg_s_base_smoother_type, psb_ipk_
class(amg_s_poly_smoother_type), intent(inout) :: sm
class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_poly_smoother_clone
end interface
interface
subroutine amg_s_poly_smoother_clone_settings(sm,smout,info)
import :: amg_s_poly_smoother_type, psb_spk_, &
& amg_s_base_smoother_type, psb_ipk_
class(amg_s_poly_smoother_type), intent(inout) :: sm
class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_poly_smoother_clone_settings
end interface
interface
subroutine amg_s_poly_smoother_clear_data(sm,info)
import :: amg_s_poly_smoother_type, psb_spk_, &
& amg_s_base_smoother_type, psb_ipk_
class(amg_s_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_poly_smoother_clear_data
end interface
interface
subroutine amg_s_poly_smoother_descr(sm,info,iout,coarse,prefix)
import :: amg_s_poly_smoother_type, psb_ipk_
class(amg_s_poly_smoother_type), intent(in) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
end subroutine amg_s_poly_smoother_descr
end interface
interface
subroutine amg_s_poly_smoother_cseti(sm,what,val,info,idx)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_s_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_s_poly_smoother_cseti
end interface
interface
subroutine amg_s_poly_smoother_csetc(sm,what,val,info,idx)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_s_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_s_poly_smoother_csetc
end interface
interface
subroutine amg_s_poly_smoother_csetr(sm,what,val,info,idx)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_s_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_s_poly_smoother_csetr
end interface
contains
subroutine s_poly_smoother_free(sm,info)
Implicit None
! Arguments
class(amg_s_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_poly_smoother_free'
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(sm%sv)) then
call sm%sv%free(info)
if (info == psb_success_) deallocate(sm%sv,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
end if
if (allocated(sm%poly_beta)) deallocate(sm%poly_beta)
sm%pa => null()
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_poly_smoother_free
function s_poly_smoother_sizeof(sm) result(val)
implicit none
! Arguments
class(amg_s_poly_smoother_type), intent(in) :: sm
integer(psb_epk_) :: val
val = psb_sizeof_dp
if (allocated(sm%sv)) val = val + sm%sv%sizeof()
if (allocated(sm%poly_beta)) val = val + psb_sizeof_dp * size(sm%poly_beta)
return
end function s_poly_smoother_sizeof
subroutine s_poly_smoother_default(sm)
Implicit None
! Arguments
class(amg_s_poly_smoother_type), intent(inout) :: sm
!
! Default: BJAC with no residual check
!
sm%pdegree = 1
sm%rho_ba = -sone
sm%variant = amg_poly_lottes_
sm%rho_estimate = amg_poly_rho_est_power_
sm%rho_estimate_iterations = 20
if (allocated(sm%sv)) then
call sm%sv%default()
end if
return
end subroutine s_poly_smoother_default
function s_poly_smoother_get_nzeros(sm) result(val)
implicit none
! Arguments
class(amg_s_poly_smoother_type), intent(in) :: sm
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = 0
if (allocated(sm%sv)) val = val + sm%sv%get_nzeros()
return
end function s_poly_smoother_get_nzeros
function s_poly_smoother_get_wrksize(sm) result(val)
implicit none
class(amg_s_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 4
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function s_poly_smoother_get_wrksize
function s_poly_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Polynomial smoother"
end function s_poly_smoother_get_fmt
function s_poly_smoother_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_poly_
end function s_poly_smoother_get_id
end module amg_s_poly_smoother

17
amgprec/amg_s_prec_type.f90
Unescape Escape View File

@ -139,6 +139,7 @@ module amg_s_prec_type
procedure, pass(prec) :: smoothers_build => amg_s_smoothers_bld
procedure, pass(prec) :: smoothers_free => amg_s_smoothers_free
procedure, pass(prec) :: descr => amg_sfile_prec_descr
procedure, pass(prec) :: memory_use => amg_sfile_prec_memory_use
end type amg_sprec_type
private :: amg_s_dump, amg_s_get_compl, amg_s_cmp_compl,&
@ -170,6 +171,22 @@ module amg_s_prec_type
end subroutine amg_sfile_prec_descr
end interface
interface amg_memory_use
subroutine amg_sfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
import :: amg_sprec_type, psb_ipk_
implicit none
! Arguments
class(amg_sprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_sfile_prec_memory_use
end interface
interface amg_sizeof
module procedure amg_sprec_sizeof
end interface

14
amgprec/amg_z_ilu_solver.f90
Unescape Escape View File

@ -234,7 +234,7 @@ contains
! Arguments
class(amg_z_ilu_solver_type), intent(inout) :: sv
sv%fact_type = psb_ilu_n_
sv%fact_type = amg_ilu_n_
sv%fill_in = 0
sv%thresh = dzero
@ -255,13 +255,13 @@ contains
info = psb_success_
call amg_check_def(sv%fact_type,&
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(psb_ilu_n_,psb_milu_n_)
case(amg_ilu_n_,amg_milu_n_)
call amg_check_def(sv%fill_in,&
& 'Level',izero,is_int_non_negative)
case(psb_ilu_t_)
case(amg_ilu_t_)
call amg_check_def(sv%thresh,&
& 'Eps',dzero,is_legal_d_fact_thrs)
end select
@ -439,9 +439,9 @@ contains
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
& amg_fact_names(sv%fact_type)
select case(sv%fact_type)
case(psb_ilu_n_,psb_milu_n_)
case(amg_ilu_n_,amg_milu_n_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
case(psb_ilu_t_)
case(amg_ilu_t_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
end select
@ -496,7 +496,7 @@ contains
implicit none
integer(psb_ipk_) :: val
val = psb_ilu_n_
val = amg_ilu_n_
end function z_ilu_solver_get_id
function z_ilu_solver_get_wrksize() result(val)

18
amgprec/amg_z_onelev_mod.f90
Unescape Escape View File

@ -187,6 +187,7 @@ module amg_z_onelev_mod
procedure, pass(lv) :: clone => z_base_onelev_clone
procedure, pass(lv) :: cnv => amg_z_base_onelev_cnv
procedure, pass(lv) :: descr => amg_z_base_onelev_descr
procedure, pass(lv) :: memory_use => amg_z_base_onelev_memory_use
procedure, pass(lv) :: default => z_base_onelev_default
procedure, pass(lv) :: free => amg_z_base_onelev_free
procedure, pass(lv) :: free_smoothers => amg_z_base_onelev_free_smoothers
@ -273,6 +274,23 @@ module amg_z_onelev_mod
end subroutine amg_z_base_onelev_descr
end interface
interface
subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
Implicit None
! Arguments
class(amg_z_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_z_base_onelev_memory_use
end interface
interface
subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
import :: amg_z_onelev_type, psb_z_base_vect_type, psb_dpk_, &

17
amgprec/amg_z_prec_type.f90
Unescape Escape View File

@ -139,6 +139,7 @@ module amg_z_prec_type
procedure, pass(prec) :: smoothers_build => amg_z_smoothers_bld
procedure, pass(prec) :: smoothers_free => amg_z_smoothers_free
procedure, pass(prec) :: descr => amg_zfile_prec_descr
procedure, pass(prec) :: memory_use => amg_zfile_prec_memory_use
end type amg_zprec_type
private :: amg_z_dump, amg_z_get_compl, amg_z_cmp_compl,&
@ -170,6 +171,22 @@ module amg_z_prec_type
end subroutine amg_zfile_prec_descr
end interface
interface amg_memory_use
subroutine amg_zfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
import :: amg_zprec_type, psb_ipk_
implicit none
! Arguments
class(amg_zprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_zfile_prec_memory_use
end interface
interface amg_sizeof
module procedure amg_zprec_sizeof
end interface

8
amgprec/impl/Makefile
Unescape Escape View File

@ -22,22 +22,22 @@ MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS)
MPCOBJS=amg_dslud_interface.o amg_zslud_interface.o
DINNEROBJS= amg_dmlprec_bld.o amg_dfile_prec_descr.o \
DINNEROBJS= amg_dmlprec_bld.o amg_dfile_prec_descr.o amg_dfile_prec_memory_use.o \
amg_d_smoothers_bld.o amg_d_hierarchy_bld.o amg_d_hierarchy_rebld.o \
amg_dmlprec_aply.o \
$(DMPFOBJS) amg_d_extprol_bld.o
SINNEROBJS= amg_smlprec_bld.o amg_sfile_prec_descr.o \
SINNEROBJS= amg_smlprec_bld.o amg_sfile_prec_descr.o amg_sfile_prec_memory_use.o \
amg_s_smoothers_bld.o amg_s_hierarchy_bld.o amg_s_hierarchy_rebld.o \
amg_smlprec_aply.o \
$(SMPFOBJS) amg_s_extprol_bld.o
ZINNEROBJS= amg_zmlprec_bld.o amg_zfile_prec_descr.o \
ZINNEROBJS= amg_zmlprec_bld.o amg_zfile_prec_descr.o amg_zfile_prec_memory_use.o \
amg_z_smoothers_bld.o amg_z_hierarchy_bld.o amg_z_hierarchy_rebld.o \
amg_zmlprec_aply.o \
$(ZMPFOBJS) amg_z_extprol_bld.o
CINNEROBJS= amg_cmlprec_bld.o amg_cfile_prec_descr.o \
CINNEROBJS= amg_cmlprec_bld.o amg_cfile_prec_descr.o amg_cfile_prec_memory_use.o \
amg_c_smoothers_bld.o amg_c_hierarchy_bld.o amg_c_hierarchy_rebld.o \
amg_cmlprec_aply.o \
$(CMPFOBJS) amg_c_extprol_bld.o

44
amgprec/impl/aggregator/MatchBoxPC.cpp
Unescape Escape View File

@ -67,12 +67,13 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
#endif
#define TIME_TRACKER
#ifdef TIME_TRACKER
double tmr = MPI_Wtime();
#endif
#undef TIME_TRACKER
#ifdef TIME_TRACKER
double tmr = MPI_Wtime();
#endif
#ifdef OPENMP
#if defined(OPENMP)
//fprintf(stderr,"Warning: using buggy OpenMP matching!\n");
dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge,
verLocPtr, verLocInd, edgeLocWeight,
verDistance, Mate,
@ -91,11 +92,11 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
#endif
#ifdef TIME_TRACKER
tmr = MPI_Wtime() - tmr;
fprintf(stderr, "Elaboration time: %f for %ld nodes\n", tmr, NLVer);
#endif
#ifdef TIME_TRACKER
tmr = MPI_Wtime() - tmr;
fprintf(stderr, "Elaboration time: %f for %ld nodes\n", tmr, NLVer);
#endif
#endif
}
@ -113,13 +114,24 @@ void sMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
fprintf(stderr,"MatchBoxPC: rank %d nlver %ld nledge %ld [ %ld %ld ]\n",
myRank,NLVer, NLEdge,verDistance[0],verDistance[1]);
#endif
#if defined(OPENMP)
//fprintf(stderr,"Warning: using buggy OpenMP matching!\n");
salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge,
verLocPtr, verLocInd, edgeLocWeight,
verDistance, Mate,
myRank, numProcs, C_comm,
msgIndSent, msgActualSent, msgPercent,
ph0_time, ph1_time, ph2_time,
ph1_card, ph2_card );
#else
salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(NLVer, NLEdge,
verLocPtr, verLocInd, edgeLocWeight,
verDistance, Mate,
myRank, numProcs, C_comm,
msgIndSent, msgActualSent, msgPercent,
ph0_time, ph1_time, ph2_time,
ph1_card, ph2_card );
verLocPtr, verLocInd, edgeLocWeight,
verDistance, Mate,
myRank, numProcs, C_comm,
msgIndSent, msgActualSent, msgPercent,
ph0_time, ph1_time, ph2_time,
ph1_card, ph2_card );
#endif
#endif
}

660
amgprec/impl/aggregator/MatchBoxPC.h
Unescape Escape View File

@ -59,7 +59,11 @@
#include <assert.h>
#include <map>
#include <vector>
#ifdef OPENMP
// OpenMP is included and used if and only if the OpenMP version of the matching
// is required
#include "omp.h"
#endif
#include "primitiveDataTypeDefinitions.h"
#include "dataStrStaticQueue.h"
@ -177,252 +181,416 @@ extern "C"
#define MilanRealMin MINUS_INFINITY
#endif
// Function of find the owner of a ghost vertex using binary search:
MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
MilanInt myRank, MilanInt numProcs);
MilanLongInt firstComputeCandidateMate(MilanLongInt adj1,
MilanLongInt adj2,
MilanLongInt *verLocInd,
MilanReal *edgeLocWeight);
void queuesTransfer(vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
bool isAlreadyMatched(MilanLongInt node,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
MilanLongInt computeCandidateMate(MilanLongInt adj1,
MilanLongInt adj2,
MilanReal *edgeLocWeight,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt StartIndex, MilanLongInt EndIndex,
MilanLongInt *numGhostEdgesPtr,
MilanLongInt *numGhostVerticesPtr,
MilanLongInt *S,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &Counter,
vector<MilanLongInt> &verGhostPtr,
vector<MilanLongInt> &verGhostInd,
vector<MilanLongInt> &tempCounter,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Message,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
MilanLongInt *&candidateMate,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void clean(MilanLongInt NLVer,
MilanInt myRank,
MilanLongInt MessageIndex,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus,
MilanInt BufferSize,
MilanLongInt *Buffer,
MilanLongInt msgActual,
MilanLongInt *msgActualSent,
MilanLongInt msgInd,
MilanLongInt *msgIndSent,
MilanLongInt NumMessagesBundled,
MilanReal *msgPercent);
void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanInt myRank,
MilanReal *edgeLocWeight,
MilanLongInt *candidateMate);
void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer,
MilanLongInt *candidateMate,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *Mate,
vector<MilanLongInt> &GMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void PROCESS_CROSS_EDGE(MilanLongInt *edge,
MilanLongInt *SPtr);
void processMatchedVertices(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void processMatchedVerticesAndSendMessages(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner,
MPI_Comm comm,
MilanLongInt *msgActual,
vector<MilanLongInt> &Message);
void sendBundledMessages(MilanLongInt *numGhostEdgesPtr,
MilanInt *BufferSizePtr,
MilanLongInt *Buffer,
vector<MilanLongInt> &PCumulative,
vector<MilanLongInt> &PMessageBundle,
vector<MilanLongInt> &PSizeInfoMessages,
MilanLongInt *PCounter,
MilanLongInt NumMessagesBundled,
MilanLongInt *msgActualPtr,
MilanLongInt *MessageIndexPtr,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus);
void processMessages(
MilanLongInt NLVer,
MilanLongInt *Mate,
MilanLongInt *candidateMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Counter,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *msgActualPtr,
MilanReal *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *verLocPtr,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &Message,
MilanLongInt numGhostEdges,
MilanLongInt u,
MilanLongInt v,
MilanLongInt *SPtr,
vector<MilanLongInt> &U);
void extractUChunk(
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU);
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
/* These functions are only used in the experimental OMP implementation, if that
is disabled there is no reason to actually compile or reference them. */
// Function of find the owner of a ghost vertex using binary search:
MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
MilanInt myRank, MilanInt numProcs);
MilanLongInt firstComputeCandidateMateD(MilanLongInt adj1,
MilanLongInt adj2,
MilanLongInt *verLocInd,
MilanReal *edgeLocWeight);
void queuesTransfer(vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
bool isAlreadyMatched(MilanLongInt node,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
MilanLongInt computeCandidateMateD(MilanLongInt adj1,
MilanLongInt adj2,
MilanReal *edgeLocWeight,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt StartIndex, MilanLongInt EndIndex,
MilanLongInt *numGhostEdgesPtr,
MilanLongInt *numGhostVerticesPtr,
MilanLongInt *S,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &Counter,
vector<MilanLongInt> &verGhostPtr,
vector<MilanLongInt> &verGhostInd,
vector<MilanLongInt> &tempCounter,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Message,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
MilanLongInt *&candidateMate,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void clean(MilanLongInt NLVer,
MilanInt myRank,
MilanLongInt MessageIndex,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus,
MilanInt BufferSize,
MilanLongInt *Buffer,
MilanLongInt msgActual,
MilanLongInt *msgActualSent,
MilanLongInt msgInd,
MilanLongInt *msgIndSent,
MilanLongInt NumMessagesBundled,
MilanReal *msgPercent);
void PARALLEL_COMPUTE_CANDIDATE_MATE_BD(MilanLongInt NLVer,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanInt myRank,
MilanReal *edgeLocWeight,
MilanLongInt *candidateMate);
void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(MilanLongInt NLVer,
MilanLongInt *candidateMate,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *Mate,
vector<MilanLongInt> &GMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void PROCESS_CROSS_EDGE(MilanLongInt *edge,
MilanLongInt *SPtr);
void processMatchedVerticesD(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void processMatchedVerticesAndSendMessagesD(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner,
MPI_Comm comm,
MilanLongInt *msgActual,
vector<MilanLongInt> &Message);
void sendBundledMessages(MilanLongInt *numGhostEdgesPtr,
MilanInt *BufferSizePtr,
MilanLongInt *Buffer,
vector<MilanLongInt> &PCumulative,
vector<MilanLongInt> &PMessageBundle,
vector<MilanLongInt> &PSizeInfoMessages,
MilanLongInt *PCounter,
MilanLongInt NumMessagesBundled,
MilanLongInt *msgActualPtr,
MilanLongInt *MessageIndexPtr,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus);
void processMessagesD(
MilanLongInt NLVer,
MilanLongInt *Mate,
MilanLongInt *candidateMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Counter,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *msgActualPtr,
MilanReal *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *verLocPtr,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &Message,
MilanLongInt numGhostEdges,
MilanLongInt u,
MilanLongInt v,
MilanLongInt *SPtr,
vector<MilanLongInt> &U);
void extractUChunk(
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU);
MilanLongInt firstComputeCandidateMateS(MilanLongInt adj1,
MilanLongInt adj2,
MilanLongInt *verLocInd,
MilanFloat *edgeLocWeight);
MilanLongInt computeCandidateMateS(MilanLongInt adj1,
MilanLongInt adj2,
MilanFloat *edgeLocWeight,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
void PARALLEL_COMPUTE_CANDIDATE_MATE_BS(MilanLongInt NLVer,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanInt myRank,
MilanFloat *edgeLocWeight,
MilanLongInt *candidateMate);
void PARALLEL_PROCESS_EXPOSED_VERTEX_BS(MilanLongInt NLVer,
MilanLongInt *candidateMate,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *Mate,
vector<MilanLongInt> &GMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanFloat *edgeLocWeight,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void processMatchedVerticesS(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanFloat *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void processMatchedVerticesAndSendMessagesS(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanFloat *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner,
MPI_Comm comm,
MilanLongInt *msgActual,
vector<MilanLongInt> &Message);
void processMessagesS(
MilanLongInt NLVer,
MilanLongInt *Mate,
MilanLongInt *candidateMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Counter,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *msgActualPtr,
MilanFloat *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *verLocPtr,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &Message,
MilanLongInt numGhostEdges,
MilanLongInt u,
MilanLongInt v,
MilanLongInt *SPtr,
vector<MilanLongInt> &U);
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanFloat *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
MilanLongInt NLVer, MilanLongInt NLEdge,

20
amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.cpp
Unescape Escape View File

@ -1303,16 +1303,16 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
// SINGLE PRECISION VERSION
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt* verLocPtr, MilanLongInt* verLocInd,
MilanFloat* edgeLocWeight,
MilanLongInt* verDistance,
MilanLongInt* Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent,
MilanReal* msgPercent,
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt* verLocPtr, MilanLongInt* verLocInd,
MilanFloat* edgeLocWeight,
MilanLongInt* verDistance,
MilanLongInt* Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent,
MilanReal* msgPercent,
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
#if !defined(SERIAL_MPI)
#ifdef PRINT_DEBUG_INFO_
cout<<"\n("<<myRank<<")Within algoEdgeApproxDominatingEdgesLinearSearchMessageBundling()"; fflush(stdout);

495
amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp
Unescape Escape View File

@ -1,5 +1,4 @@
#include "MatchBoxPC.h"
#ifdef OPENMP
// ***********************************************************************
//
// MatchboxP: A C++ library for approximate weighted matching
@ -244,7 +243,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
* PARALLEL_COMPUTE_CANDIDATE_MATE_B is now totally parallel.
*/
PARALLEL_COMPUTE_CANDIDATE_MATE_B(NLVer,
PARALLEL_COMPUTE_CANDIDATE_MATE_BD(NLVer,
verLocPtr,
verLocInd,
myRank,
@ -269,7 +268,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
* TODO: Test when it's actually more efficient to execute this code
* in parallel.
*/
PARALLEL_PROCESS_EXPOSED_VERTEX_B(NLVer,
PARALLEL_PROCESS_EXPOSED_VERTEX_BD(NLVer,
candidateMate,
verLocInd,
verLocPtr,
@ -321,7 +320,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
vector<MilanLongInt> UChunkBeingProcessed;
UChunkBeingProcessed.reserve(UCHUNK);
processMatchedVertices(NLVer,
processMatchedVerticesD(NLVer,
UChunkBeingProcessed,
U,
privateU,
@ -430,7 +429,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
/////////////////////////// PROCESS MATCHED VERTICES //////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
processMatchedVerticesAndSendMessages(NLVer,
processMatchedVerticesAndSendMessagesD(NLVer,
UChunkBeingProcessed,
U,
privateU,
@ -490,8 +489,8 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
///////////////////////////////////////////////////////////////////////////////////
/////////////////////////// PROCESS MESSAGES //////////////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
processMessages(NLVer,
//startTime = MPI_Wtime();
processMessagesD(NLVer,
Mate,
candidateMate,
Ghost2LocalMap,
@ -556,6 +555,488 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
*ph2_card = myCard; // Cardinality at the end of Phase-2
}
// End of algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMate
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt *verLocPtr, MilanLongInt *verLocInd,
MilanFloat *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent,
MilanReal *msgPercent,
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
MilanLongInt *ph1_card, MilanLongInt *ph2_card)
{
/*
* verDistance: it's a vector long as the number of processors.
* verDistance[i] contains the first node index of the i-th processor
* verDistance[i + 1] contains the last node index of the i-th processor
* NLVer: number of elements in the LocPtr
* NLEdge: number of edges assigned to the current processor
*
* Contains the portion of matrix assigned to the processor in
* Yale notation
* verLocInd: contains the positions on row of the matrix
* verLocPtr: i-th value is the position of the first element on the i-th row and
* i+1-th value is the position of the first element on the i+1-th row
*/
#if !defined(SERIAL_MPI)
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Within algoEdgeApproxDominatingEdgesLinearSearchMessageBundling()";
fflush(stdout);
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ") verDistance [" ;
for (int i = 0; i < numProcs; i++)
cout << verDistance[i] << "," << verDistance[i+1];
cout << "]\n";
fflush(stdout);
#endif
#ifdef DEBUG_HANG_
if (myRank == 0) {
cout << "\n(" << myRank << ") verDistance [" ;
for (int i = 0; i < numProcs; i++)
cout << verDistance[i] << "," ;
cout << verDistance[numProcs]<< "]\n";
}
fflush(stdout);
#endif
// The starting vertex owned by the current rank
MilanLongInt StartIndex = verDistance[myRank];
// The ending vertex owned by the current rank
MilanLongInt EndIndex = verDistance[myRank + 1] - 1;
MPI_Status computeStatus;
MilanLongInt msgActual = 0, msgInd = 0;
MilanFloat heaviestEdgeWt = 0.0f; // Assumes positive weight
MilanReal startTime, finishTime;
startTime = MPI_Wtime();
// Data structures for sending and receiving messages:
vector<MilanLongInt> Message; // [ u, v, message_type ]
Message.resize(3, -1);
// Data structures for Message Bundling:
// Although up to two messages can be sent along any cross edge,
// only one message will be sent in the initialization phase -
// one of: REQUEST/FAILURE/SUCCESS
vector<MilanLongInt> QLocalVtx, QGhostVtx, QMsgType;
// Changed by Fabio to be an integer, addresses needs to be integers!
vector<MilanInt> QOwner;
MilanLongInt *PCounter = new MilanLongInt[numProcs];
for (int i = 0; i < numProcs; i++)
PCounter[i] = 0;
MilanLongInt NumMessagesBundled = 0;
// TODO when the last computational section will be refactored this could be eliminated
// Changed by Fabio to be an integer, addresses needs to be integers!
MilanInt ghostOwner = 0;
MilanLongInt *candidateMate = nullptr;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")NV: " << NLVer << " Edges: " << NLEdge;
fflush(stdout);
cout << "\n(" << myRank << ")StartIndex: " << StartIndex << " EndIndex: " << EndIndex;
fflush(stdout);
#endif
// Other Variables:
MilanLongInt u = -1, v = -1, w = -1, i = 0;
MilanLongInt k = -1, adj1 = -1, adj2 = -1;
MilanLongInt k1 = -1, adj11 = -1, adj12 = -1;
MilanLongInt myCard = 0;
// Build the Ghost Vertex Set: Vg
// Map each ghost vertex to a local vertex
map<MilanLongInt, MilanLongInt> Ghost2LocalMap;
// Store the edge count for each ghost vertex
vector<MilanLongInt> Counter;
// Number of Ghost vertices
MilanLongInt numGhostVertices = 0, numGhostEdges = 0;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")About to compute Ghost Vertices...";
fflush(stdout);
#endif
#ifdef DEBUG_HANG_
if (myRank == 0)
cout << "\n(" << myRank << ")About to compute Ghost Vertices...";
fflush(stdout);
#endif
// Define Adjacency Lists for Ghost Vertices:
// cout<<"Building Ghost data structures ... \n\n";
vector<MilanLongInt> verGhostPtr, verGhostInd, tempCounter;
// Mate array for ghost vertices:
vector<MilanLongInt> GMate; // Proportional to the number of ghost vertices
MilanLongInt S;
MilanLongInt privateMyCard = 0;
vector<MilanLongInt> PCumulative, PMessageBundle, PSizeInfoMessages;
vector<MPI_Request> SRequest; // Requests that are used for each send message
vector<MPI_Status> SStatus; // Status of sent messages, used in MPI_Wait
MilanLongInt MessageIndex = 0; // Pointer for current message
MilanInt BufferSize;
MilanLongInt *Buffer;
vector<MilanLongInt> privateQLocalVtx, privateQGhostVtx, privateQMsgType;
vector<MilanInt> privateQOwner;
vector<MilanLongInt> U, privateU;
initialize(NLVer, NLEdge, StartIndex,
EndIndex, &numGhostEdges,
&numGhostVertices, &S,
verLocInd, verLocPtr,
Ghost2LocalMap, Counter,
verGhostPtr, verGhostInd,
tempCounter, GMate,
Message, QLocalVtx,
QGhostVtx, QMsgType, QOwner,
candidateMate, U,
privateU,
privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
finishTime = MPI_Wtime();
*ph0_time = finishTime - startTime; // Time taken for Phase-0: Initialization
#ifdef DEBUG_HANG_
cout << myRank << " Finished initialization" << endl;
fflush(stdout);
#endif
startTime = MPI_Wtime();
/////////////////////////////////////////////////////////////////////////////////////////
//////////////////////////////////// INITIALIZATION /////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////
// Compute the Initial Matching Set:
/*
* OMP PARALLEL_COMPUTE_CANDIDATE_MATE_B has been splitted from
* PARALLEL_PROCESS_EXPOSED_VERTEX_B in order to better parallelize
* the two.
* PARALLEL_COMPUTE_CANDIDATE_MATE_B is now totally parallel.
*/
PARALLEL_COMPUTE_CANDIDATE_MATE_BS(NLVer,
verLocPtr,
verLocInd,
myRank,
edgeLocWeight,
candidateMate);
#ifdef DEBUG_HANG_
cout << myRank << " Finished Exposed Vertex" << endl;
fflush(stdout);
#if 0
cout << myRank << " candidateMate after parallelCompute " <<endl;
for (int i=0; i<NLVer; i++) {
cout << candidateMate[i] << " " ;
}
cout << endl;
#endif
#endif
/*
* PARALLEL_PROCESS_EXPOSED_VERTEX_B
* TODO: write comment
*
* TODO: Test when it's actually more efficient to execute this code
* in parallel.
*/
PARALLEL_PROCESS_EXPOSED_VERTEX_BS(NLVer,
candidateMate,
verLocInd,
verLocPtr,
StartIndex,
EndIndex,
Mate,
GMate,
Ghost2LocalMap,
edgeLocWeight,
&myCard,
&msgInd,
&NumMessagesBundled,
&S,
verDistance,
PCounter,
Counter,
myRank,
numProcs,
U,
privateU,
QLocalVtx,
QGhostVtx,
QMsgType,
QOwner,
privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
tempCounter.clear(); // Do not need this any more
#ifdef DEBUG_HANG_
cout << myRank << " Finished Exposed Vertex" << endl;
fflush(stdout);
#if 0
cout << myRank << " Mate after Exposed Vertices " <<endl;
for (int i=0; i<NLVer; i++) {
cout << Mate[i] << " " ;
}
cout << endl;
#endif
#endif
///////////////////////////////////////////////////////////////////////////////////
/////////////////////////// PROCESS MATCHED VERTICES //////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
// TODO what would be the optimal UCHUNK
vector<MilanLongInt> UChunkBeingProcessed;
UChunkBeingProcessed.reserve(UCHUNK);
processMatchedVerticesS(NLVer,
UChunkBeingProcessed,
U,
privateU,
StartIndex,
EndIndex,
&myCard,
&msgInd,
&NumMessagesBundled,
&S,
verLocPtr,
verLocInd,
verDistance,
PCounter,
Counter,
myRank,
numProcs,
candidateMate,
GMate,
Mate,
Ghost2LocalMap,
edgeLocWeight,
QLocalVtx,
QGhostVtx,
QMsgType,
QOwner,
privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
#ifdef DEBUG_HANG_
cout << myRank << " Finished Process Vertices" << endl;
fflush(stdout);
#if 0
cout << myRank << " Mate after Matched Vertices " <<endl;
for (int i=0; i<NLVer; i++) {
cout << Mate[i] << " " ;
}
cout << endl;
#endif
#endif
/////////////////////////////////////////////////////////////////////////////////////////
///////////////////////////// SEND BUNDLED MESSAGES /////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////
sendBundledMessages(&numGhostEdges,
&BufferSize,
Buffer,
PCumulative,
PMessageBundle,
PSizeInfoMessages,
PCounter,
NumMessagesBundled,
&msgActual,
&MessageIndex,
numProcs,
myRank,
comm,
QLocalVtx,
QGhostVtx,
QMsgType,
QOwner,
SRequest,
SStatus);
///////////////////////// END OF SEND BUNDLED MESSAGES //////////////////////////////////
finishTime = MPI_Wtime();
*ph1_time = finishTime - startTime; // Time taken for Phase-1
#ifdef DEBUG_HANG_
cout << myRank << " Finished sendBundles" << endl;
fflush(stdout);
#endif
*ph1_card = myCard; // Cardinality at the end of Phase-1
startTime = MPI_Wtime();
/////////////////////////////////////////////////////////////////////////////////////////
//////////////////////////////////////// MAIN LOOP //////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////
// Main While Loop:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << "=========================************===============================" << endl;
fflush(stdout);
fflush(stdout);
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Entering While(true) loop..";
fflush(stdout);
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << "=========================************===============================" << endl;
fflush(stdout);
fflush(stdout);
#endif
while (true) {
#ifdef DEBUG_HANG_
//if (myRank == 0)
cout << "\n(" << myRank << ") Main loop" << endl;
fflush(stdout);
#endif
///////////////////////////////////////////////////////////////////////////////////
/////////////////////////// PROCESS MATCHED VERTICES //////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
processMatchedVerticesAndSendMessagesS(NLVer,
UChunkBeingProcessed,
U,
privateU,
StartIndex,
EndIndex,
&myCard,
&msgInd,
&NumMessagesBundled,
&S,
verLocPtr,
verLocInd,
verDistance,
PCounter,
Counter,
myRank,
numProcs,
candidateMate,
GMate,
Mate,
Ghost2LocalMap,
edgeLocWeight,
QLocalVtx,
QGhostVtx,
QMsgType,
QOwner,
privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner,
comm,
&msgActual,
Message);
///////////////////////// END OF PROCESS MATCHED VERTICES /////////////////////////
//// BREAK IF NO MESSAGES EXPECTED /////////
#ifdef DEBUG_HANG_
#if 0
cout << myRank << " Mate after ProcessMatchedAndSend phase "<<S <<endl;
for (int i=0; i<NLVer; i++) {
cout << Mate[i] << " " ;
}
cout << endl;
#endif
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Deciding whether to break: S= " << S << endl;
#endif
if (S == 0) {
#ifdef DEBUG_HANG_
cout << "\n(" << myRank << ") Breaking out" << endl;
fflush(stdout);
#endif
break;
}
///////////////////////////////////////////////////////////////////////////////////
/////////////////////////// PROCESS MESSAGES //////////////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
processMessagesS(NLVer,
Mate,
candidateMate,
Ghost2LocalMap,
GMate,
Counter,
StartIndex,
EndIndex,
&myCard,
&msgInd,
&msgActual,
edgeLocWeight,
verDistance,
verLocPtr,
k,
verLocInd,
numProcs,
myRank,
comm,
Message,
numGhostEdges,
u,
v,
&S,
U);
///////////////////////// END OF PROCESS MESSAGES /////////////////////////////////
#ifdef DEBUG_HANG_
#if 0
cout << myRank << " Mate after ProcessMessages phase "<<S <<endl;
for (int i=0; i<NLVer; i++) {
cout << Mate[i] << " " ;
}
cout << endl;
#endif
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Finished Message processing phase: S= " << S;
fflush(stdout);
cout << "\n(" << myRank << ")** SENT : ACTUAL= " << msgActual;
fflush(stdout);
cout << "\n(" << myRank << ")** SENT : INDIVIDUAL= " << msgInd << endl;
fflush(stdout);
#endif
} // End of while (true)
clean(NLVer,
myRank,
MessageIndex,
SRequest,
SStatus,
BufferSize,
Buffer,
msgActual,
msgActualSent,
msgInd,
msgIndSent,
NumMessagesBundled,
msgPercent);
finishTime = MPI_Wtime();
*ph2_time = finishTime - startTime; // Time taken for Phase-2
*ph2_card = myCard; // Cardinality at the end of Phase-2
}
#endif
#endif

3
amgprec/impl/aggregator/amg_c_soc1_map_bld.F90
Unescape Escape View File

@ -275,7 +275,8 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)

3
amgprec/impl/aggregator/amg_c_soc2_map_bld.F90
Unescape Escape View File

@ -309,7 +309,8 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
!
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)

3
amgprec/impl/aggregator/amg_d_soc1_map_bld.F90
Unescape Escape View File

@ -275,7 +275,8 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)

3
amgprec/impl/aggregator/amg_d_soc2_map_bld.F90
Unescape Escape View File

@ -309,7 +309,8 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
!
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)

3
amgprec/impl/aggregator/amg_s_soc1_map_bld.F90
Unescape Escape View File

@ -275,7 +275,8 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)

3
amgprec/impl/aggregator/amg_s_soc2_map_bld.F90
Unescape Escape View File

@ -309,7 +309,8 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
!
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)

3
amgprec/impl/aggregator/amg_z_soc1_map_bld.F90
Unescape Escape View File

@ -275,7 +275,8 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)

3
amgprec/impl/aggregator/amg_z_soc2_map_bld.F90
Unescape Escape View File

@ -309,7 +309,8 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
!
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)

1
amgprec/impl/aggregator/clean.cpp
Unescape Escape View File

@ -1,5 +1,4 @@
#include "MatchBoxPC.h"
// TODO comment
#if !defined(SERIAL_MPI)

74
amgprec/impl/aggregator/computeCandidateMate.cpp
Unescape Escape View File

@ -1,5 +1,4 @@
#include "MatchBoxPC.h"
/**
* Execute the research fr the Candidate Mate without controlling if the vertices are already matched.
* Returns the vertices with the highest weight
@ -9,9 +8,8 @@
* @param edgeLocWeight
* @return
*/
#if !defined(SERIAL_MPI)
MilanLongInt firstComputeCandidateMate(MilanLongInt adj1,
MilanLongInt firstComputeCandidateMateD(MilanLongInt adj1,
MilanLongInt adj2,
MilanLongInt *verLocInd,
MilanReal *edgeLocWeight)
@ -44,7 +42,7 @@ MilanLongInt firstComputeCandidateMate(MilanLongInt adj1,
* @param Ghost2LocalMap
* @return
*/
MilanLongInt computeCandidateMate(MilanLongInt adj1,
MilanLongInt computeCandidateMateD(MilanLongInt adj1,
MilanLongInt adj2,
MilanReal *edgeLocWeight,
MilanLongInt k,
@ -62,7 +60,7 @@ MilanLongInt computeCandidateMate(MilanLongInt adj1,
for (k = adj1; k < adj2; k++) {
if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap))
continue;
if ((edgeLocWeight[k] > heaviestEdgeWt) ||
((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k]))) {
heaviestEdgeWt = edgeLocWeight[k];
@ -70,7 +68,71 @@ MilanLongInt computeCandidateMate(MilanLongInt adj1,
}
} // End of for loop
// End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
return w;
}
MilanLongInt firstComputeCandidateMateS(MilanLongInt adj1,
MilanLongInt adj2,
MilanLongInt *verLocInd,
MilanFloat *edgeLocWeight)
{
MilanInt w = -1;
MilanFloat heaviestEdgeWt = 0.0f; // Assign the smallest
int finalK;
for (int k = adj1; k < adj2; k++) {
if ((edgeLocWeight[k] > heaviestEdgeWt) ||
((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k]))) {
heaviestEdgeWt = edgeLocWeight[k];
w = verLocInd[k];
finalK = k;
}
} // End of for loop
return finalK;
}
/**
* //TODO documentation
* @param adj1
* @param adj2
* @param edgeLocWeight
* @param k
* @param verLocInd
* @param StartIndex
* @param EndIndex
* @param GMate
* @param Mate
* @param Ghost2LocalMap
* @return
*/
MilanLongInt computeCandidateMateS(MilanLongInt adj1,
MilanLongInt adj2,
MilanFloat *edgeLocWeight,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap)
{
// Start: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
MilanInt w = -1;
MilanFloat heaviestEdgeWt = 0.0f; // Assign the smallest Value
for (k = adj1; k < adj2; k++) {
if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap))
continue;
if ((edgeLocWeight[k] > heaviestEdgeWt) ||
((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k]))) {
heaviestEdgeWt = edgeLocWeight[k];
w = verLocInd[k];
}
} // End of for loop
// End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
return w;
}
#endif

3
amgprec/impl/aggregator/extractUChunk.cpp
Unescape Escape View File

@ -1,5 +1,4 @@
#include "MatchBoxPC.h"
void extractUChunk(
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
@ -28,4 +27,4 @@ void extractUChunk(
}
} // End of critical U // End of critical U
}
}

1
amgprec/impl/aggregator/findOwnerOfGhost.cpp
Unescape Escape View File

@ -1,5 +1,4 @@
#include "MatchBoxPC.h"
/// Find the owner of a ghost node:
MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
MilanInt myRank, MilanInt numProcs)

3
amgprec/impl/aggregator/initialize.cpp
Unescape Escape View File

@ -1,5 +1,4 @@
#include "MatchBoxPC.h"
void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt StartIndex, MilanLongInt EndIndex,
MilanLongInt *numGhostEdges,
@ -291,7 +290,7 @@ void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
//new (&U) staticQueue(NLVer + (*numGhostVertices));
U.reserve(NLVer + (*numGhostVertices));
// Initialize the private vectors
// Initialize the private vectors
privateQLocalVtx.reserve(*numGhostVertices);
privateQGhostVtx.reserve(*numGhostVertices);
privateQMsgType.reserve(*numGhostVertices);

5
amgprec/impl/aggregator/isAlreadyMatched.cpp
Unescape Escape View File

@ -1,5 +1,4 @@
#include "MatchBoxPC.h"
/**
* //TODO documentation
* @param k
@ -32,7 +31,7 @@ bool isAlreadyMatched(MilanLongInt node,
*/
MilanLongInt val;
if ((node < StartIndex) || (node > EndIndex)) // if ghost vertex
{
{
#pragma omp atomic read
val = GMate[Ghost2LocalMap[node]];
return val >= 0; // Already matched
@ -43,4 +42,4 @@ bool isAlreadyMatched(MilanLongInt node,
val = Mate[node - StartIndex];
return val >= 0; // Already matched
}
}

33
amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp
Unescape Escape View File

@ -1,7 +1,6 @@
#include "MatchBoxPC.h"
#if !defined(SERIAL_MPI)
void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer,
void PARALLEL_COMPUTE_CANDIDATE_MATE_BD(MilanLongInt NLVer,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanInt myRank,
@ -21,7 +20,35 @@ void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer,
fflush(stdout);
#endif
// Start: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
candidateMate[v] = firstComputeCandidateMate(verLocPtr[v], verLocPtr[v + 1], verLocInd, edgeLocWeight);
candidateMate[v] = firstComputeCandidateMateD(verLocPtr[v], verLocPtr[v + 1],
verLocInd, edgeLocWeight);
// End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
}
}
}
void PARALLEL_COMPUTE_CANDIDATE_MATE_BS(MilanLongInt NLVer,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanInt myRank,
MilanFloat *edgeLocWeight,
MilanLongInt *candidateMate)
{
MilanLongInt v = -1;
#pragma omp parallel private(v) default(shared) num_threads(NUM_THREAD)
{
#pragma omp for schedule(static)
for (v = 0; v < NLVer; v++) {
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Processing: " << v + StartIndex << endl;
fflush(stdout);
#endif
// Start: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
candidateMate[v] = firstComputeCandidateMateS(verLocPtr[v], verLocPtr[v + 1],
verLocInd, edgeLocWeight);
// End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
}
}

3
amgprec/impl/aggregator/processCrossEdge.cpp
Unescape Escape View File

@ -1,5 +1,4 @@
#include "MatchBoxPC.h"
void PROCESS_CROSS_EDGE(MilanLongInt *edge,
MilanLongInt *S)
{
@ -21,4 +20,4 @@ void PROCESS_CROSS_EDGE(MilanLongInt *edge,
#endif
// End: PARALLEL_PROCESS_CROSS_EDGE_B
}
}

203
amgprec/impl/aggregator/processExposedVertex.cpp
Unescape Escape View File

@ -1,6 +1,5 @@
#include "MatchBoxPC.h"
#ifdef OPENMP
void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer,
#include "MatchBoxPC.h"
void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(MilanLongInt NLVer,
MilanLongInt *candidateMate,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
@ -31,15 +30,16 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer,
vector<MilanInt> &privateQOwner)
{
MilanLongInt v = -1, k = -1, w = -1, adj11 = 0, adj12 = 0, k1 = 0;
MilanLongInt v = -1, k = -1, w = -1, adj11 = 0, adj12 = 0, k1 = 0;
MilanInt ghostOwner = 0, option, igw;
#pragma omp parallel private(option, k, w, v, k1, adj11, adj12, ghostOwner) \
firstprivate(privateU, StartIndex, EndIndex, privateQLocalVtx, privateQGhostVtx, privateQMsgType, privateQOwner) \
default(shared) num_threads(NUM_THREAD)
//#pragma omp parallel private(option, k, w, v, k1, adj11, adj12, ghostOwner) \
firstprivate(privateU, StartIndex, EndIndex, privateQLocalVtx, \
privateQGhostVtx, privateQMsgType, privateQOwner) \
default(shared) num_threads(NUM_THREAD)
{
#pragma omp for reduction(+ \
//#pragma omp for reduction(+ \
: PCounter[:numProcs], myCard \
[:1], msgInd \
[:1], NumMessagesBundled \
@ -66,7 +66,7 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer,
#pragma omp critical(Matching)
{
if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap)) {
w = computeCandidateMate(verLocPtr[v], verLocPtr[v + 1], edgeLocWeight, 0,
w = computeCandidateMateD(verLocPtr[v], verLocPtr[v + 1], edgeLocWeight, 0,
verLocInd, StartIndex, EndIndex,
GMate, Mate, Ghost2LocalMap);
candidateMate[v] = w;
@ -181,4 +181,189 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer,
} // End of parallel region
}
void PARALLEL_PROCESS_EXPOSED_VERTEX_BS(MilanLongInt NLVer,
MilanLongInt *candidateMate,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *Mate,
vector<MilanLongInt> &GMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanFloat *edgeLocWeight,
MilanLongInt *myCard,
MilanLongInt *msgInd,
MilanLongInt *NumMessagesBundled,
MilanLongInt *S,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner)
{
MilanLongInt v = -1, k = -1, w = -1, adj11 = 0, adj12 = 0, k1 = 0;
MilanInt ghostOwner = 0, option, igw;
//#pragma omp parallel private(option, k, w, v, k1, adj11, adj12, ghostOwner) \
firstprivate(privateU, StartIndex, EndIndex, privateQLocalVtx, \
privateQGhostVtx, privateQMsgType, privateQOwner) \
default(shared) num_threads(NUM_THREAD)
{
//#pragma omp for reduction(+ \
: PCounter[:numProcs], myCard \
[:1], msgInd \
[:1], NumMessagesBundled \
[:1]) \
schedule(static)
for (v = 0; v < NLVer; v++) {
option = -1;
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
k = candidateMate[v];
candidateMate[v] = verLocInd[k];
w = candidateMate[v];
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Processing: " << v + StartIndex << endl;
fflush(stdout);
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")" << v + StartIndex << " Points to: " << w;
fflush(stdout);
#endif
// If found a dominating edge:
if (w >= 0) {
#pragma omp critical(Matching)
{
if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap)) {
w = computeCandidateMateS(verLocPtr[v], verLocPtr[v + 1], edgeLocWeight, 0,
verLocInd, StartIndex, EndIndex,
GMate, Mate, Ghost2LocalMap);
candidateMate[v] = w;
}
if (w >= 0) {
(*myCard)++;
if ((w < StartIndex) || (w > EndIndex)) { // w is a ghost vertex
option = 2;
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v + StartIndex) {
option = 1;
Mate[v] = w;
GMate[Ghost2LocalMap[w]] = v + StartIndex; // w is a Ghost
} // End of if CandidateMate[w] = v
} // End of if a Ghost Vertex
else { // w is a local vertex
if (candidateMate[w - StartIndex] == (v + StartIndex)) {
option = 3;
Mate[v] = w; // v is local
Mate[w - StartIndex] = v + StartIndex; // w is local
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v + StartIndex << "," << w << ") ";
fflush(stdout);
#endif
} // End of if ( candidateMate[w-StartIndex] == (v+StartIndex) )
} // End of Else
} // End of second if
}
} // End of if(w >=0)
else {
//#pragma omp critical(adjuse)
{
// This piece of code is executed a really small number of times
adj11 = verLocPtr[v];
adj12 = verLocPtr[v + 1];
for (k1 = adj11; k1 < adj12; k1++) {
w = verLocInd[k1];
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a failure message: ";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
fflush(stdout);
#endif
(*msgInd)++;
(*NumMessagesBundled)++;
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// assert(ghostOwner != -1);
// assert(ghostOwner != myRank);
#pragma omp atomic
PCounter[ghostOwner]++;
privateQLocalVtx.push_back(v + StartIndex);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(FAILURE);
privateQOwner.push_back(ghostOwner);
} // End of if(GHOST)
} // End of for loop
}
}
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
switch (option)
{
case -1:
break;
case 1:
privateU.push_back(v + StartIndex);
privateU.push_back(w);
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v + StartIndex << "," << w << ")";
fflush(stdout);
#endif
// Decrement the counter:
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], S);
case 2:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a request message (291):";
cout << "\n(" << myRank << ")Local is: " << v + StartIndex << " Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs) << endl;
fflush(stdout);
#endif
(*msgInd)++;
(*NumMessagesBundled)++;
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// assert(ghostOwner != -1);
// assert(ghostOwner != myRank);
#pragma omp atomic
PCounter[ghostOwner]++;
privateQLocalVtx.push_back(v + StartIndex);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(REQUEST);
privateQOwner.push_back(ghostOwner);
break;
case 3:
default:
privateU.push_back(v + StartIndex);
privateU.push_back(w);
break;
}
} // End of for ( v=0; v < NLVer; v++ )
queuesTransfer(U, privateU, QLocalVtx,
QGhostVtx,
QMsgType, QOwner, privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
} // End of parallel region
}
#endif

445
amgprec/impl/aggregator/processMatchedVertices.cpp
Unescape Escape View File

@ -1,7 +1,5 @@
#include "MatchBoxPC.h"
#if !defined(SERIAL_MPI)
void processMatchedVertices(
void processMatchedVerticesD(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
@ -59,29 +57,29 @@ void processMatchedVertices(
{
while (!U.empty()) {
extractUChunk(UChunkBeingProcessed, U, privateU);
for (MilanLongInt u : UChunkBeingProcessed) {
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")u: " << u;
fflush(stdout);
#endif
if ((u >= StartIndex) && (u <= EndIndex)) { // Process Only the Local Vertices
#ifdef COUNT_LOCAL_VERTEX
localVertices++;
#endif
// Get the Adjacency list for u
adj1 = verLocPtr[u - StartIndex]; // Pointer
adj2 = verLocPtr[u - StartIndex + 1];
for (k = adj1; k < adj2; k++) {
option = -1;
v = verLocInd[k];
if ((v >= StartIndex) && (v <= EndIndex)) { // If Local Vertex:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")v: " << v << " c(v)= " << candidateMate[v - StartIndex] << " Mate[v]: " << Mate[v];
fflush(stdout);
@ -92,62 +90,62 @@ void processMatchedVertices(
if (mateVal < 0) {
#pragma omp critical
{
if (candidateMate[v - StartIndex] == u) {
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
w = computeCandidateMate(verLocPtr[v - StartIndex],
verLocPtr[v - StartIndex + 1],
edgeLocWeight, 0,
verLocInd,
StartIndex,
EndIndex,
GMate,
Mate,
Ghost2LocalMap);
candidateMate[v - StartIndex] = w;
#pragma omp atomic read
mateVal = Mate[v - StartIndex];
// If the current vertex is pointing to a matched vertex and is not matched
if (mateVal < 0) {
if (candidateMate[v - StartIndex] == u) {
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
w = computeCandidateMateD(verLocPtr[v - StartIndex],
verLocPtr[v - StartIndex + 1],
edgeLocWeight, 0,
verLocInd, StartIndex, EndIndex,
GMate, Mate, Ghost2LocalMap);
candidateMate[v - StartIndex] = w;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
fflush(stdout);
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
fflush(stdout);
#endif
// If found a dominating edge:
if (w >= 0) {
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
// If found a dominating edge:
if (w >= 0) {
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a request message:";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
cout << "\n(" << myRank << ")Sending a request message:";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
#endif
option = 2;
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
option = 1;
Mate[v - StartIndex] = w; // v is a local vertex
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
} // End of if CandidateMate[w] = v
} // End of if a Ghost Vertex
else { // w is a local vertex
if (candidateMate[w - StartIndex] == v) {
option = 3;
Mate[v - StartIndex] = w; // v is a local vertex
Mate[w - StartIndex] = v; // w is a local vertex
option = 2;
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
option = 1;
Mate[v - StartIndex] = w; // v is a local vertex
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
} // End of if CandidateMate[w] = v
} // End of if a Ghost Vertex
else { // w is a local vertex
if (candidateMate[w - StartIndex] == v) {
option = 3;
Mate[v - StartIndex] = w; // v is a local vertex
Mate[w - StartIndex] = v; // w is a local vertex
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
fflush(stdout);
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
fflush(stdout);
#endif
} // End of if(CandidateMate(w) = v
} // End of Else
} // End of if(w >=0)
else
option = 4; // End of Else: w == -1
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
} // End of If (candidateMate[v-StartIndex] == u
} // End of if(CandidateMate(w) = v
} // End of Else
} // End of if(w >=0)
else
option = 4; // End of Else: w == -1
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
} // End of If (candidateMate[v-StartIndex] == u
}
} // End of task
} // mateval < 0
} // End of if ( (v >= StartIndex) && (v <= EndIndex) ) //If Local Vertex:
else { // Neighbor is a ghost vertex
#pragma omp critical
{
if (candidateMate[NLVer + Ghost2LocalMap[v]] == u)
@ -156,7 +154,7 @@ void processMatchedVertices(
option = 5; // u is local
} // End of critical
} // End of Else //A Ghost Vertex
switch (option)
{
case -1:
@ -166,7 +164,7 @@ void processMatchedVertices(
// Found a dominating edge, it is a ghost and candidateMate[NLVer + Ghost2LocalMap[w]] == v
privateU.push_back(v);
privateU.push_back(w);
(*myCard)++;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
@ -175,15 +173,16 @@ void processMatchedVertices(
// Decrement the counter:
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], SPtr);
case 2:
// Found a dominating edge, it is a ghost
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// assert(ghostOwner != -1);
// assert(ghostOwner != myRank);
#pragma omp atomic
PCounter[ghostOwner]++;
(*NumMessagesBundled)++;
(*msgInd)++;
privateQLocalVtx.push_back(v);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(REQUEST);
@ -192,7 +191,7 @@ void processMatchedVertices(
case 3:
privateU.push_back(v);
privateU.push_back(w);
(*myCard)++;
break;
case 4:
@ -202,94 +201,384 @@ void processMatchedVertices(
for (k1 = adj11; k1 < adj12; k1++) {
w = verLocInd[k1];
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a failure message: ";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// assert(ghostOwner != -1);
// assert(ghostOwner != myRank);
#pragma omp atomic
PCounter[ghostOwner]++;
(*NumMessagesBundled)++;
(*msgInd)++;
privateQLocalVtx.push_back(v);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(FAILURE);
privateQOwner.push_back(ghostOwner);
} // End of if(GHOST)
} // End of for loop
break;
case 5:
default:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a success message: ";
cout << "\n(" << myRank << ")Ghost is " << v << " Owner is: " << findOwnerOfGhost(v, verDistance, myRank, numProcs) << "\n";
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(v, verDistance, myRank, numProcs);
// assert(ghostOwner != -1);
// assert(ghostOwner != myRank);
(*NumMessagesBundled)++;
PCounter[ghostOwner]++;
(*msgInd)++;
privateQLocalVtx.push_back(u);
privateQGhostVtx.push_back(v);
privateQMsgType.push_back(SUCCESS);
privateQOwner.push_back(ghostOwner);
break;
} // End of switch
} // End of inner for
}
} // End of outer for
queuesTransfer(U, privateU, QLocalVtx,
QGhostVtx,
QMsgType, QOwner, privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
#pragma omp critical(U)
{
U.insert(U.end(), privateU.begin(), privateU.end());
}
#pragma omp critical(sendMessageTransfer)
{
QLocalVtx.insert(QLocalVtx.end(), privateQLocalVtx.begin(), privateQLocalVtx.end());
QGhostVtx.insert(QGhostVtx.end(), privateQGhostVtx.begin(), privateQGhostVtx.end());
QMsgType.insert(QMsgType.end(), privateQMsgType.begin(), privateQMsgType.end());
QOwner.insert(QOwner.end(), privateQOwner.begin(), privateQOwner.end());
}
privateU.clear();
privateQLocalVtx.clear();
privateQGhostVtx.clear();
privateQMsgType.clear();
privateQOwner.clear();
} // End of while ( !U.empty() )
#ifdef COUNT_LOCAL_VERTEX
printf("Count local vertexes: %ld for thread %d of processor %d\n",
localVertices,
omp_get_thread_num(),
myRank);
#endif
} // End of parallel region
}
void processMatchedVerticesS(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCard,
MilanLongInt *msgInd,
MilanLongInt *NumMessagesBundled,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanFloat *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner)
{
MilanLongInt adj1, adj2, adj11, adj12, k, k1, v = -1, w = -1, ghostOwner;
int option;
MilanLongInt mateVal;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << "=========================************===============================" << endl;
fflush(stdout);
fflush(stdout);
#endif
#ifdef COUNT_LOCAL_VERTEX
MilanLongInt localVertices = 0;
#endif
//#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \
firstprivate(privateU, StartIndex, EndIndex, privateQLocalVtx, privateQGhostVtx, \
privateQMsgType, privateQOwner, UChunkBeingProcessed) \
default(shared) num_threads(NUM_THREAD) \
reduction(+ \
: msgInd[:1], PCounter \
[:numProcs], myCard \
[:1], NumMessagesBundled \
[:1])
{
while (!U.empty()) {
extractUChunk(UChunkBeingProcessed, U, privateU);
for (MilanLongInt u : UChunkBeingProcessed) {
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")u: " << u;
fflush(stdout);
#endif
if ((u >= StartIndex) && (u <= EndIndex)) { // Process Only the Local Vertices
#ifdef COUNT_LOCAL_VERTEX
localVertices++;
#endif
// Get the Adjacency list for u
adj1 = verLocPtr[u - StartIndex]; // Pointer
adj2 = verLocPtr[u - StartIndex + 1];
for (k = adj1; k < adj2; k++) {
option = -1;
v = verLocInd[k];
if ((v >= StartIndex) && (v <= EndIndex)) { // If Local Vertex:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")v: " << v << " c(v)= " << candidateMate[v - StartIndex] << " Mate[v]: " << Mate[v];
fflush(stdout);
#endif
#pragma omp atomic read
mateVal = Mate[v - StartIndex];
// If the current vertex is pointing to a matched vertex and is not matched
if (mateVal < 0) {
#pragma omp critical
{
#pragma omp atomic read
mateVal = Mate[v - StartIndex];
// If the current vertex is pointing to a matched vertex and is not matched
if (mateVal < 0) {
if (candidateMate[v - StartIndex] == u) {
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
w = computeCandidateMateS(verLocPtr[v - StartIndex],
verLocPtr[v - StartIndex + 1],
edgeLocWeight, 0,
verLocInd, StartIndex, EndIndex,
GMate, Mate, Ghost2LocalMap);
candidateMate[v - StartIndex] = w;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
fflush(stdout);
#endif
// If found a dominating edge:
if (w >= 0) {
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a request message:";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
#endif
option = 2;
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
option = 1;
Mate[v - StartIndex] = w; // v is a local vertex
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
} // End of if CandidateMate[w] = v
} // End of if a Ghost Vertex
else { // w is a local vertex
if (candidateMate[w - StartIndex] == v) {
option = 3;
Mate[v - StartIndex] = w; // v is a local vertex
Mate[w - StartIndex] = v; // w is a local vertex
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
fflush(stdout);
#endif
} // End of if(CandidateMate(w) = v
} // End of Else
} // End of if(w >=0)
else
option = 4; // End of Else: w == -1
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
} // End of If (candidateMate[v-StartIndex] == u
}
} // End of task
} // mateval < 0
} // End of if ( (v >= StartIndex) && (v <= EndIndex) ) //If Local Vertex:
else { // Neighbor is a ghost vertex
#pragma omp critical
{
if (candidateMate[NLVer + Ghost2LocalMap[v]] == u)
candidateMate[NLVer + Ghost2LocalMap[v]] = -1;
if (v != Mate[u - StartIndex])
option = 5; // u is local
} // End of critical
} // End of Else //A Ghost Vertex
switch (option)
{
case -1:
// No things to do
break;
case 1:
// Found a dominating edge, it is a ghost and candidateMate[NLVer + Ghost2LocalMap[w]] == v
privateU.push_back(v);
privateU.push_back(w);
(*myCard)++;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
fflush(stdout);
#endif
// Decrement the counter:
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], SPtr);
case 2:
// Found a dominating edge, it is a ghost
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// assert(ghostOwner != -1);
// assert(ghostOwner != myRank);
#pragma omp atomic
PCounter[ghostOwner]++;
(*NumMessagesBundled)++;
(*msgInd)++;
privateQLocalVtx.push_back(v);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(REQUEST);
privateQOwner.push_back(ghostOwner);
break;
case 3:
privateU.push_back(v);
privateU.push_back(w);
(*myCard)++;
break;
case 4:
// Could not find a dominating vertex
adj11 = verLocPtr[v - StartIndex];
adj12 = verLocPtr[v - StartIndex + 1];
for (k1 = adj11; k1 < adj12; k1++) {
w = verLocInd[k1];
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a failure message: ";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// assert(ghostOwner != -1);
// assert(ghostOwner != myRank);
#pragma omp atomic
PCounter[ghostOwner]++;
(*NumMessagesBundled)++;
(*msgInd)++;
privateQLocalVtx.push_back(v);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(FAILURE);
privateQOwner.push_back(ghostOwner);
} // End of if(GHOST)
} // End of for loop
break;
case 5:
default:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a success message: ";
cout << "\n(" << myRank << ")Ghost is " << v << " Owner is: " << findOwnerOfGhost(v, verDistance, myRank, numProcs) << "\n";
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(v, verDistance, myRank, numProcs);
// assert(ghostOwner != -1);
// assert(ghostOwner != myRank);
(*NumMessagesBundled)++;
PCounter[ghostOwner]++;
(*msgInd)++;
privateQLocalVtx.push_back(u);
privateQGhostVtx.push_back(v);
privateQMsgType.push_back(SUCCESS);
privateQOwner.push_back(ghostOwner);
break;
} // End of switch
} // End of inner for
}
} // End of outer for
queuesTransfer(U, privateU, QLocalVtx,
QGhostVtx,
QMsgType, QOwner, privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
#pragma omp critical(U)
{
U.insert(U.end(), privateU.begin(), privateU.end());
}
#pragma omp critical(sendMessageTransfer)
{
QLocalVtx.insert(QLocalVtx.end(), privateQLocalVtx.begin(), privateQLocalVtx.end());
QGhostVtx.insert(QGhostVtx.end(), privateQGhostVtx.begin(), privateQGhostVtx.end());
QMsgType.insert(QMsgType.end(), privateQMsgType.begin(), privateQMsgType.end());
QOwner.insert(QOwner.end(), privateQOwner.begin(), privateQOwner.end());
}
privateU.clear();
privateQLocalVtx.clear();
privateQGhostVtx.clear();
privateQMsgType.clear();
privateQOwner.clear();
} // End of while ( !U.empty() )
#ifdef COUNT_LOCAL_VERTEX
printf("Count local vertexes: %ld for thread %d of processor %d\n",
localVertices,
omp_get_thread_num(),
myRank);
#endif
} // End of parallel region
}

441
amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp
Unescape Escape View File

@ -1,7 +1,6 @@
#include "MatchBoxPC.h"
//#define DEBUG_HANG_
#if !defined(SERIAL_MPI)
void processMatchedVerticesAndSendMessages(
void processMatchedVerticesAndSendMessagesD(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
@ -27,6 +26,302 @@ void processMatchedVerticesAndSendMessages(
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner,
MPI_Comm comm,
MilanLongInt *msgActual,
vector<MilanLongInt> &Message)
{
MilanLongInt initialSize = QLocalVtx.size();
MilanLongInt adj1, adj2, adj11, adj12, k, k1, v = -1, w = -1, ghostOwner;
int option;
MilanLongInt mateVal;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << "=========================************===============================" << endl;
fflush(stdout);
fflush(stdout);
#endif
#ifdef COUNT_LOCAL_VERTEX
MilanLongInt localVertices = 0;
#endif
//#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \
firstprivate(Message, privateU, StartIndex, EndIndex, privateQLocalVtx, \
privateQGhostVtx, privateQMsgType, privateQOwner, UChunkBeingProcessed) \
default(shared) \
num_threads(NUM_THREAD) \
reduction(+ \
: msgInd[:1], PCounter \
[:numProcs], myCard \
[:1], NumMessagesBundled \
[:1], msgActual \
[:1])
{
while (!U.empty()) {
extractUChunk(UChunkBeingProcessed, U, privateU);
for (MilanLongInt u : UChunkBeingProcessed) {
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")u: " << u;
fflush(stdout);
#endif
if ((u >= StartIndex) && (u <= EndIndex)) { // Process Only the Local Vertices
#ifdef COUNT_LOCAL_VERTEX
localVertices++;
#endif
// Get the Adjacency list for u
adj1 = verLocPtr[u - StartIndex]; // Pointer
adj2 = verLocPtr[u - StartIndex + 1];
for (k = adj1; k < adj2; k++) {
option = -1;
v = verLocInd[k];
if ((v >= StartIndex) && (v <= EndIndex)) { // If Local Vertex:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")v: " << v << " c(v)= " << candidateMate[v - StartIndex] << " Mate[v]: " << Mate[v];
fflush(stdout);
#endif
#pragma omp atomic read
mateVal = Mate[v - StartIndex];
// If the current vertex is pointing to a matched vertex and is not matched
if (mateVal < 0) {
#pragma omp critical
{
#pragma omp atomic read
mateVal = Mate[v - StartIndex];
// If the current vertex is pointing to a matched vertex and is not matched
if (mateVal < 0) {
if (candidateMate[v - StartIndex] == u) {
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
w = computeCandidateMateD(verLocPtr[v - StartIndex],
verLocPtr[v - StartIndex + 1],
edgeLocWeight, 0,
verLocInd, StartIndex, EndIndex,
GMate, Mate, Ghost2LocalMap);
candidateMate[v - StartIndex] = w;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
fflush(stdout);
#endif
// If found a dominating edge:
if (w >= 0) {
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a request message:";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
#endif
option = 2;
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
option = 1;
Mate[v - StartIndex] = w; // v is a local vertex
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
} // End of if CandidateMate[w] = v
} // End of if a Ghost Vertex
else { // w is a local vertex
if (candidateMate[w - StartIndex] == v) {
option = 3;
Mate[v - StartIndex] = w; // v is a local vertex
Mate[w - StartIndex] = v; // w is a local vertex
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
fflush(stdout);
#endif
} // End of if(CandidateMate(w) = v
} // End of Else
} // End of if(w >=0)
else
option = 4; // End of Else: w == -1
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
} // End of If (candidateMate[v-StartIndex] == u
}
} // End of task
} // mateval < 0
} // End of if ( (v >= StartIndex) && (v <= EndIndex) ) //If Local Vertex:
else { // Neighbor is a ghost vertex
#pragma omp critical
{
if (candidateMate[NLVer + Ghost2LocalMap[v]] == u)
candidateMate[NLVer + Ghost2LocalMap[v]] = -1;
if (v != Mate[u - StartIndex])
option = 5; // u is local
} // End of critical
} // End of Else //A Ghost Vertex
switch (option)
{
case -1:
// No things to do
break;
case 1:
// Found a dominating edge, it is a ghost and candidateMate[NLVer + Ghost2LocalMap[w]] == v
privateU.push_back(v);
privateU.push_back(w);
(*myCard)++;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
fflush(stdout);
#endif
// Decrement the counter:
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], SPtr);
case 2:
// Found a dominating edge, it is a ghost
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// Build the Message Packet:
// Message[0] = v; // LOCAL
// Message[1] = w; // GHOST
// Message[2] = REQUEST; // TYPE
// Send a Request (Asynchronous)
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
(*msgActual)++;
(*msgInd)++;
privateQLocalVtx.push_back(v);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(REQUEST);
privateQOwner.push_back(ghostOwner);
break;
case 3:
privateU.push_back(v);
privateU.push_back(w);
(*myCard)++;
break;
case 4:
// Could not find a dominating vertex
adj11 = verLocPtr[v - StartIndex];
adj12 = verLocPtr[v - StartIndex + 1];
for (k1 = adj11; k1 < adj12; k1++) {
w = verLocInd[k1];
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a failure message: ";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// Build the Message Packet:
// Message[0] = v; // LOCAL
// Message[1] = w; // GHOST
// Message[2] = FAILURE; // TYPE
// Send a Request (Asynchronous)
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
(*msgActual)++;
(*msgInd)++;
privateQLocalVtx.push_back(v);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(FAILURE);
privateQOwner.push_back(ghostOwner);
} // End of if(GHOST)
} // End of for loop
break;
case 5:
default:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a success message: ";
cout << "\n(" << myRank << ")Ghost is " << v << " Owner is: " << findOwnerOfGhost(v, verDistance, myRank, numProcs) << "\n";
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(v, verDistance, myRank, numProcs);
// Build the Message Packet:
// Message[0] = u; // LOCAL
// Message[1] = v; // GHOST
// Message[2] = SUCCESS; // TYPE
// Send a Request (Asynchronous)
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
(*msgActual)++;
(*msgInd)++;
privateQLocalVtx.push_back(u);
privateQGhostVtx.push_back(v);
privateQMsgType.push_back(SUCCESS);
privateQOwner.push_back(ghostOwner);
break;
} // End of switch
} // End of inner for
}
} // End of outer for
queuesTransfer(U, privateU, QLocalVtx,
QGhostVtx,
QMsgType, QOwner, privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
} // End of while ( !U.empty() )
#ifdef COUNT_LOCAL_VERTEX
printf("Count local vertexes: %ld for thread %d of processor %d\n",
localVertices, mp_get_thread_num(), myRank);
#endif
} // End of parallel region
// Send the messages
#ifdef DEBUG_HANG_
cout << myRank<<" Sending: "<<QOwner.size()-initialSize<<" messages" <<endl;
#endif
for (int i = initialSize; i < QOwner.size(); i++) {
Message[0] = QLocalVtx[i];
Message[1] = QGhostVtx[i];
Message[2] = QMsgType[i];
ghostOwner = QOwner[i];
//MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
}
#ifdef DEBUG_HANG_
cout << myRank<<" Done sending messages"<<endl;
#endif
}
void processMatchedVerticesAndSendMessagesS(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCard,
MilanLongInt *msgInd,
MilanLongInt *NumMessagesBundled,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanFloat *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
@ -64,29 +359,28 @@ void processMatchedVerticesAndSendMessages(
{
while (!U.empty()) {
extractUChunk(UChunkBeingProcessed, U, privateU);
for (MilanLongInt u : UChunkBeingProcessed) {
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")u: " << u;
fflush(stdout);
#endif
if ((u >= StartIndex) && (u <= EndIndex)) { // Process Only the Local Vertices
#ifdef COUNT_LOCAL_VERTEX
localVertices++;
#endif
// Get the Adjacency list for u
adj1 = verLocPtr[u - StartIndex]; // Pointer
adj2 = verLocPtr[u - StartIndex + 1];
for (k = adj1; k < adj2; k++) {
option = -1;
v = verLocInd[k];
if ((v >= StartIndex) && (v <= EndIndex)) { // If Local Vertex:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")v: " << v << " c(v)= " << candidateMate[v - StartIndex] << " Mate[v]: " << Mate[v];
fflush(stdout);
@ -97,63 +391,62 @@ void processMatchedVerticesAndSendMessages(
if (mateVal < 0) {
#pragma omp critical
{
if (candidateMate[v - StartIndex] == u) {
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
w = computeCandidateMate(verLocPtr[v - StartIndex],
verLocPtr[v - StartIndex + 1],
edgeLocWeight, 0,
verLocInd,
StartIndex,
EndIndex,
GMate,
Mate,
Ghost2LocalMap);
candidateMate[v - StartIndex] = w;
#pragma omp atomic read
mateVal = Mate[v - StartIndex];
// If the current vertex is pointing to a matched vertex and is not matched
if (mateVal < 0) {
if (candidateMate[v - StartIndex] == u) {
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
w = computeCandidateMateS(verLocPtr[v - StartIndex],
verLocPtr[v - StartIndex + 1],
edgeLocWeight, 0,
verLocInd, StartIndex, EndIndex,
GMate, Mate, Ghost2LocalMap);
candidateMate[v - StartIndex] = w;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
fflush(stdout);
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
fflush(stdout);
#endif
// If found a dominating edge:
if (w >= 0) {
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
// If found a dominating edge:
if (w >= 0) {
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a request message:";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
cout << "\n(" << myRank << ")Sending a request message:";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
#endif
option = 2;
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
option = 1;
Mate[v - StartIndex] = w; // v is a local vertex
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
} // End of if CandidateMate[w] = v
} // End of if a Ghost Vertex
else { // w is a local vertex
if (candidateMate[w - StartIndex] == v) {
option = 3;
Mate[v - StartIndex] = w; // v is a local vertex
Mate[w - StartIndex] = v; // w is a local vertex
option = 2;
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
option = 1;
Mate[v - StartIndex] = w; // v is a local vertex
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
} // End of if CandidateMate[w] = v
} // End of if a Ghost Vertex
else { // w is a local vertex
if (candidateMate[w - StartIndex] == v) {
option = 3;
Mate[v - StartIndex] = w; // v is a local vertex
Mate[w - StartIndex] = v; // w is a local vertex
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
fflush(stdout);
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
fflush(stdout);
#endif
} // End of if(CandidateMate(w) = v
} // End of Else
} // End of if(w >=0)
else
option = 4; // End of Else: w == -1
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
} // End of If (candidateMate[v-StartIndex] == u
} // End of if(CandidateMate(w) = v
} // End of Else
} // End of if(w >=0)
else
option = 4; // End of Else: w == -1
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
} // End of If (candidateMate[v-StartIndex] == u
}
} // End of task
} // mateval < 0
} // End of if ( (v >= StartIndex) && (v <= EndIndex) ) //If Local Vertex:
else { // Neighbor is a ghost vertex
#pragma omp critical
{
if (candidateMate[NLVer + Ghost2LocalMap[v]] == u)
@ -162,7 +455,7 @@ void processMatchedVerticesAndSendMessages(
option = 5; // u is local
} // End of critical
} // End of Else //A Ghost Vertex
switch (option)
{
case -1:
@ -180,20 +473,20 @@ void processMatchedVerticesAndSendMessages(
// Decrement the counter:
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], SPtr);
case 2:
// Found a dominating edge, it is a ghost
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// Build the Message Packet:
// Message[0] = v; // LOCAL
// Message[1] = w; // GHOST
// Message[2] = REQUEST; // TYPE
// Send a Request (Asynchronous)
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
(*msgActual)++;
(*msgInd)++;
privateQLocalVtx.push_back(v);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(REQUEST);
@ -211,94 +504,82 @@ void processMatchedVerticesAndSendMessages(
for (k1 = adj11; k1 < adj12; k1++) {
w = verLocInd[k1];
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a failure message: ";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
// Build the Message Packet:
// Message[0] = v; // LOCAL
// Message[1] = w; // GHOST
// Message[2] = FAILURE; // TYPE
// Send a Request (Asynchronous)
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
(*msgActual)++;
(*msgInd)++;
privateQLocalVtx.push_back(v);
privateQGhostVtx.push_back(w);
privateQMsgType.push_back(FAILURE);
privateQOwner.push_back(ghostOwner);
} // End of if(GHOST)
} // End of for loop
break;
case 5:
default:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a success message: ";
cout << "\n(" << myRank << ")Ghost is " << v << " Owner is: " << findOwnerOfGhost(v, verDistance, myRank, numProcs) << "\n";
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(v, verDistance, myRank, numProcs);
// Build the Message Packet:
// Message[0] = u; // LOCAL
// Message[1] = v; // GHOST
// Message[2] = SUCCESS; // TYPE
// Send a Request (Asynchronous)
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
(*msgActual)++;
(*msgInd)++;
privateQLocalVtx.push_back(u);
privateQGhostVtx.push_back(v);
privateQMsgType.push_back(SUCCESS);
privateQOwner.push_back(ghostOwner);
break;
} // End of switch
} // End of inner for
}
} // End of outer for
queuesTransfer(U, privateU, QLocalVtx,
QGhostVtx,
QMsgType, QOwner, privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
} // End of while ( !U.empty() )
#ifdef COUNT_LOCAL_VERTEX
printf("Count local vertexes: %ld for thread %d of processor %d\n",
localVertices,
omp_get_thread_num(),
myRank);
localVertices, mp_get_thread_num(), myRank);
#endif
} // End of parallel region
// Send the messages
#ifdef DEBUG_HANG_
cout << myRank<<" Sending: "<<QOwner.size()-initialSize<<" messages" <<endl;
#endif
for (int i = initialSize; i < QOwner.size(); i++) {
Message[0] = QLocalVtx[i];
Message[1] = QGhostVtx[i];
Message[2] = QMsgType[i];
ghostOwner = QOwner[i];
//MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);

334
amgprec/impl/aggregator/processMessages.cpp
Unescape Escape View File

@ -2,7 +2,7 @@
//#define DEBUG_HANG_
#if !defined(SERIAL_MPI)
void processMessages(
void processMessagesD(
MilanLongInt NLVer,
MilanLongInt *Mate,
MilanLongInt *candidateMate,
@ -139,12 +139,327 @@ void processMessages(
if (!ReceiveBuffer.empty())
ReceiveBuffer.clear(); // Empty it out first
ReceiveBuffer.resize(bundleSize, -1); // Initialize
ReceiveBuffer[0] = Message[0]; // u
ReceiveBuffer[1] = Message[1]; // v
ReceiveBuffer[2] = Message[2]; // message_type
}
#ifdef DEBUG_GHOST_
if ((v < StartIndex) || (v > EndIndex)) {
cout << "\n(" << myRank << ") From ReceiveBuffer: This should not happen: u= " << u << " v= " << v << " Type= " << message_type << " StartIndex " << StartIndex << " EndIndex " << EndIndex << endl;
fflush(stdout);
}
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Processing message: u= " << u << " v= " << v << " Type= " << message_type << endl;
fflush(stdout);
#endif
// Most of the time bundleSize == 3, thus, it's not worth parallelizing thi loop
for (MilanLongInt bundleCounter = 3; bundleCounter < bundleSize + 3; bundleCounter += 3) {
u = ReceiveBuffer[bundleCounter - 3]; // GHOST
v = ReceiveBuffer[bundleCounter - 2]; // LOCAL
message_type = ReceiveBuffer[bundleCounter - 1]; // TYPE
// CASE I: REQUEST
if (message_type == REQUEST) {
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Message type is REQUEST" << endl;
fflush(stdout);
#endif
#ifdef DEBUG_GHOST_
if ((v < 0) || (v < StartIndex) || ((v - StartIndex) > NLVer)) {
cout << "\n(" << myRank << ") case 1 Bad address " << v << " " << StartIndex << " " << v - StartIndex << " " << NLVer << endl;
fflush(stdout);
}
#endif
if (Mate[v - StartIndex] == -1) {
// Process only if not already matched (v is local)
candidateMate[NLVer + Ghost2LocalMap[u]] = v; // Set CandidateMate for the ghost
if (candidateMate[v - StartIndex] == u) {
GMate[Ghost2LocalMap[u]] = v; // u is ghost
Mate[v - StartIndex] = u; // v is local
U.push_back(v);
U.push_back(u);
(*myCard)++;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << u << ") " << endl;
fflush(stdout);
#endif
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S);
} // End of if ( candidateMate[v-StartIndex] == u )e
} // End of if ( Mate[v] == -1 )
} // End of REQUEST
else { // CASE II: SUCCESS
if (message_type == SUCCESS) {
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Message type is SUCCESS" << endl;
fflush(stdout);
#endif
GMate[Ghost2LocalMap[u]] = EndIndex + 1; // Set a Dummy Mate to make sure that we do not (u is a ghost) process it again
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S);
#ifdef DEBUG_GHOST_
if ((v < 0) || (v < StartIndex) || ((v - StartIndex) > NLVer)) {
cout << "\n(" << myRank << ") case 2 Bad address " << v << " " << StartIndex << " " << v - StartIndex << " " << NLVer << endl;
fflush(stdout);
}
#endif
if (Mate[v - StartIndex] == -1) {
// Process only if not already matched ( v is local)
if (candidateMate[v - StartIndex] == u) {
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
w = computeCandidateMateD(verLocPtr[v - StartIndex], verLocPtr[v - StartIndex + 1],
edgeLocWeight, k,verLocInd, StartIndex, EndIndex,
GMate, Mate, Ghost2LocalMap);
candidateMate[v - StartIndex] = w;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")" << v << " Points to: " << w << endl;
fflush(stdout);
#endif
// If found a dominating edge:
if (w >= 0) {
if ((w < StartIndex) || (w > EndIndex)) {
// w is a ghost
// Build the Message Packet:
Message[0] = v; // LOCAL
Message[1] = w; // GHOST
Message[2] = REQUEST; // TYPE
// Send a Request (Asynchronous)
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a request message: ";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs) << endl;
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
//assert(ghostOwner != -1);
//assert(ghostOwner != myRank);
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
(*msgInd)++;
(*msgActual)++;
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
Mate[v - StartIndex] = w; // v is local
GMate[Ghost2LocalMap[w]] = v; // w is ghost
U.push_back(v);
U.push_back(w);
(*myCard)++;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") " << endl;
fflush(stdout);
#endif
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], S);
} // End of if CandidateMate[w] = v
} // End of if a Ghost Vertex
else { // w is a local vertex
if (candidateMate[w - StartIndex] == v) {
Mate[v - StartIndex] = w; // v is local
Mate[w - StartIndex] = v; // w is local
// Q.push_back(u);
U.push_back(v);
U.push_back(w);
(*myCard)++;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") " << endl;
fflush(stdout);
#endif
} // End of if(CandidateMate(w) = v
} // End of Else
} // End of if(w >=0)
else { // No dominant edge found
adj11 = verLocPtr[v - StartIndex];
adj12 = verLocPtr[v - StartIndex + 1];
for (k1 = adj11; k1 < adj12; k1++) {
w = verLocInd[k1];
if ((w < StartIndex) || (w > EndIndex)) {
// A ghost
// Build the Message Packet:
Message[0] = v; // LOCAL
Message[1] = w; // GHOST
Message[2] = FAILURE; // TYPE
// Send a Request (Asynchronous)
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Sending a failure message: ";
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs) << endl;
fflush(stdout);
#endif
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
//assert(ghostOwner != -1);
//assert(ghostOwner != myRank);
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
(*msgInd)++;
(*msgActual)++;
} // End of if(GHOST)
} // End of for loop
} // End of Else: w == -1
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
} // End of if ( candidateMate[v-StartIndex] == u )
} // End of if ( Mate[v] == -1 )
} // End of if ( message_type == SUCCESS )
else {
// CASE III: FAILURE
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Message type is FAILURE" << endl;
fflush(stdout);
#endif
GMate[Ghost2LocalMap[u]] = EndIndex + 1; // Set a Dummy Mate to make sure that we do not (u is a ghost) process this anymore
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S); // Decrease the counter
} // End of else: CASE III
} // End of else: CASE I
}
return;
}
void processMessagesS(
MilanLongInt NLVer,
MilanLongInt *Mate,
MilanLongInt *candidateMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Counter,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCard,
MilanLongInt *msgInd,
MilanLongInt *msgActual,
MilanFloat *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *verLocPtr,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &Message,
MilanLongInt numGhostEdges,
MilanLongInt u,
MilanLongInt v,
MilanLongInt *S,
vector<MilanLongInt> &U)
{
//#define PRINT_DEBUG_INFO_
MilanInt Sender;
MPI_Status computeStatus;
MilanLongInt bundleSize, w;
MilanLongInt adj11, adj12, k1;
MilanLongInt ghostOwner;
int error_codeC;
error_codeC = MPI_Comm_set_errhandler(MPI_COMM_WORLD, MPI_ERRORS_RETURN);
char error_message[MPI_MAX_ERROR_STRING];
int message_length;
MilanLongInt message_type = 0;
// Buffer to receive bundled messages
// Maximum messages that can be received from any processor is
// twice the edge cut: REQUEST; REQUEST+(FAILURE/SUCCESS)
vector<MilanLongInt> ReceiveBuffer;
try
{
ReceiveBuffer.reserve(numGhostEdges * 2 * 3); // Three integers per cross edge
}
catch (length_error)
{
cout << "Error in function algoDistEdgeApproxDominatingEdgesMessageBundling: \n";
cout << "Not enough memory to allocate the internal variables \n";
exit(1);
}
#ifdef PRINT_DEBUG_INFO_
cout
<< "\n(" << myRank << "=========================************===============================" << endl;
fflush(stdout);
fflush(stdout);
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")About to begin Message processing phase ... *S=" << *S << endl;
fflush(stdout);
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << "=========================************===============================" << endl;
fflush(stdout);
fflush(stdout);
#endif
// BLOCKING RECEIVE:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << " Waiting for blocking receive..." << endl;
fflush(stdout);
fflush(stdout);
#endif
//cout << myRank<<" Receiving ...";
error_codeC = MPI_Recv(&Message[0], 3, TypeMap<MilanLongInt>(), MPI_ANY_SOURCE, ComputeTag, comm, &computeStatus);
if (error_codeC != MPI_SUCCESS)
{
MPI_Error_string(error_codeC, error_message, &message_length);
cout << "\n*Error in call to MPI_Receive on Slave: " << error_message << "\n";
fflush(stdout);
}
Sender = computeStatus.MPI_SOURCE;
//cout << " ...from "<<Sender << endl;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Received message from Process " << Sender << " Type= " << Message[2] << endl;
fflush(stdout);
#endif
if (Message[2] == SIZEINFO) {
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Received bundled message from Process " << Sender << " Size= " << Message[0] << endl;
fflush(stdout);
#endif
bundleSize = Message[0]; //#of integers in the message
// Build the Message Buffer:
if (!ReceiveBuffer.empty())
ReceiveBuffer.clear(); // Empty it out first
ReceiveBuffer.resize(bundleSize, -1); // Initialize
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Message Bundle Before: " << endl;
for (int i = 0; i < bundleSize; i++)
cout << ReceiveBuffer[i] << ",";
cout << endl;
fflush(stdout);
#endif
// Receive the message
//cout << myRank<<" Receiving from "<<Sender<<endl;
error_codeC = MPI_Recv(&ReceiveBuffer[0], bundleSize, TypeMap<MilanLongInt>(), Sender, BundleTag, comm, &computeStatus);
if (error_codeC != MPI_SUCCESS) {
MPI_Error_string(error_codeC, error_message, &message_length);
cout << "\n*Error in call to MPI_Receive on processor " << myRank << " Error: " << error_message << "\n";
fflush(stdout);
}
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Message Bundle After: " << endl;
for (int i = 0; i < bundleSize; i++)
cout << ReceiveBuffer[i] << ",";
cout << endl;
fflush(stdout);
#endif
} else { // Just a single message:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Received regular message from Process " << Sender << " u= " << Message[0] << " v= " << Message[1] << endl;
fflush(stdout);
#endif
// Add the current message to Queue:
bundleSize = 3; //#of integers in the message
// Build the Message Buffer:
if (!ReceiveBuffer.empty())
ReceiveBuffer.clear(); // Empty it out first
ReceiveBuffer.resize(bundleSize, -1); // Initialize
ReceiveBuffer[0] = Message[0]; // u
ReceiveBuffer[1] = Message[1]; // v
ReceiveBuffer[2] = Message[2]; // message_type
}
#ifdef DEBUG_GHOST_
if ((v < StartIndex) || (v > EndIndex)) {
cout << "\n(" << myRank << ") From ReceiveBuffer: This should not happen: u= " << u << " v= " << v << " Type= " << message_type << " StartIndex " << StartIndex << " EndIndex " << EndIndex << endl;
@ -161,7 +476,7 @@ void processMessages(
u = ReceiveBuffer[bundleCounter - 3]; // GHOST
v = ReceiveBuffer[bundleCounter - 2]; // LOCAL
message_type = ReceiveBuffer[bundleCounter - 1]; // TYPE
// CASE I: REQUEST
if (message_type == REQUEST) {
#ifdef PRINT_DEBUG_INFO_
@ -189,7 +504,7 @@ void processMessages(
cout << "\n(" << myRank << ")MATCH: (" << v << "," << u << ") " << endl;
fflush(stdout);
#endif
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S);
} // End of if ( candidateMate[v-StartIndex] == u )e
} // End of if ( Mate[v] == -1 )
@ -212,8 +527,9 @@ void processMessages(
// Process only if not already matched ( v is local)
if (candidateMate[v - StartIndex] == u) {
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
w = computeCandidateMate(verLocPtr[v - StartIndex], verLocPtr[v - StartIndex + 1], edgeLocWeight, k,
verLocInd, StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap);
w = computeCandidateMateS(verLocPtr[v - StartIndex], verLocPtr[v - StartIndex + 1],
edgeLocWeight, k,verLocInd, StartIndex, EndIndex,
GMate, Mate, Ghost2LocalMap);
candidateMate[v - StartIndex] = w;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")" << v << " Points to: " << w << endl;
@ -250,7 +566,7 @@ void processMessages(
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") " << endl;
fflush(stdout);
#endif
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], S);
} // End of if CandidateMate[w] = v
} // End of if a Ghost Vertex
@ -311,7 +627,7 @@ void processMessages(
} // End of else: CASE III
} // End of else: CASE I
}
return;
}
#endif

1
amgprec/impl/aggregator/queueTransfer.cpp
Unescape Escape View File

@ -1,5 +1,4 @@
#include "MatchBoxPC.h"
#ifdef OPENMP
void queuesTransfer(vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,

43
amgprec/impl/aggregator/sendBundledMessages.cpp
Unescape Escape View File

@ -1,24 +1,23 @@
#include "MatchBoxPC.h"
#if !defined(SERIAL_MPI)
void sendBundledMessages(MilanLongInt *numGhostEdges,
MilanInt *BufferSize,
MilanLongInt *Buffer,
vector<MilanLongInt> &PCumulative,
vector<MilanLongInt> &PMessageBundle,
vector<MilanLongInt> &PSizeInfoMessages,
MilanLongInt *PCounter,
MilanLongInt NumMessagesBundled,
MilanLongInt *msgActual,
MilanLongInt *msgInd,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus)
MilanInt *BufferSize,
MilanLongInt *Buffer,
vector<MilanLongInt> &PCumulative,
vector<MilanLongInt> &PMessageBundle,
vector<MilanLongInt> &PSizeInfoMessages,
MilanLongInt *PCounter,
MilanLongInt NumMessagesBundled,
MilanLongInt *msgActual,
MilanLongInt *msgInd,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus)
{
MilanLongInt myIndex = 0, numMessagesToSend;
@ -62,7 +61,7 @@ void sendBundledMessages(MilanLongInt *numGhostEdges,
for (i = 0; i < numProcs; i++)
PCumulative[i + 1] = PCumulative[i] + PCounter[i];
}
#pragma omp task depend(inout \
: PCounter)
{
@ -84,7 +83,7 @@ void sendBundledMessages(MilanLongInt *numGhostEdges,
PCounter[QOwner[i]]++;
}
}
// Send the Bundled Messages: Use ISend
#pragma omp task depend(out \
: SRequest, SStatus)
@ -101,7 +100,7 @@ void sendBundledMessages(MilanLongInt *numGhostEdges,
exit(1);
}
}
// Send the Messages
#pragma omp task depend(inout \
: SRequest, PSizeInfoMessages, PCumulative) depend(out \

67
amgprec/impl/amg_c_hierarchy_bld.f90 → amgprec/impl/amg_c_hierarchy_bld.F90
Unescape Escape View File

@ -507,6 +507,71 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
return
contains
#if ( __GNUC__ == 13 && __GNUC_MINOR__ == 3)
! gfortran 13.3.0 generates a strange error here with MOLD
! moving to SOURCE but only for this version, since it's heavier
subroutine save_smoothers(level,save1, save2,info)
type(amg_c_onelev_type), intent(inout) :: level
class(amg_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) call level%sm%clone_settings(save1,info)
if ((info == 0).and.allocated(level%sm2a)) then
allocate(save2, source=level%sm2a,stat=info)
if (info == 0) call level%sm2a%clone_settings(save2,info)
end if
return
end subroutine save_smoothers
subroutine restore_smoothers(level,save1, save2,info)
type(amg_c_onelev_type), intent(inout), target :: level
class(amg_c_base_smoother_type), allocatable, intent(inout) :: 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)
if (info == 0) call save1%clone_settings(level%sm,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) call save2%clone_settings(level%sm2a,info)
if (info == 0) level%sm2 => level%sm2a
else
if (allocated(level%sm)) level%sm2 => level%sm
end if
return
end subroutine restore_smoothers
#else
subroutine save_smoothers(level,save1, save2,info)
type(amg_c_onelev_type), intent(inout) :: level
class(amg_c_base_smoother_type), allocatable , intent(inout) :: save1, save2
@ -565,5 +630,5 @@ contains
return
end subroutine restore_smoothers
#endif
end subroutine amg_c_hierarchy_bld

4
amgprec/impl/amg_c_smoothers_bld.f90
Unescape Escape View File

@ -186,8 +186,8 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& ' but it has been changed to distributed.'
end if
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
case(amg_ilu_n_, amg_ilu_t_,amg_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= amg_ilu_n_) then
write(psb_err_unit,*) &
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
& amg_fact_names(coarse_solve_id)

36
amgprec/impl/amg_ccprecset.F90
Unescape Escape View File

@ -485,7 +485,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -499,7 +499,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -522,7 +522,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -530,21 +530,21 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#endif
case('ILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('ILUT')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('MILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
@ -559,7 +559,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -582,7 +582,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -606,7 +606,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -714,7 +714,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -727,7 +727,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -750,7 +750,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -758,21 +758,21 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#endif
case('ILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('ILUT')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('MILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
@ -787,7 +787,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -810,7 +810,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -834,7 +834,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)

2
amgprec/impl/amg_cfile_prec_descr.f90
Unescape Escape View File

@ -170,7 +170,7 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
call prec%precv(1)%sm%descr(info,iout=iout_,prefix=prefix)
nswps = prec%precv(1)%parms%sweeps_pre
end if
write(iout_,*) trim(prefix_), ' Number of sweeps : ',nswps
write(iout_,*) trim(prefix_), ' Number of sweeps/degree : ',nswps
write(iout_,*) trim(prefix_)
else if (nlev > 1) then

152
amgprec/impl/amg_cfile_prec_memory_use.f90
Unescape Escape View File

@ -0,0 +1,152 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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: amg_dfile_prec_memory_use.f90
!
!
! Subroutine: amg_file_prec_memory_use
! Version: complex
!
! This routine prints a memory_useiption of the preconditioner to the standard
! output or to a file. It must be called after the preconditioner has been
! built by amg_precbld.
!
! Arguments:
! p - type(amg_Tprec_type), input.
! The preconditioner data structure to be printed out.
! info - integer, output.
! error code.
! iout - integer, input, optional.
! The id of the file where the preconditioner description
! will be printed. If iout is not present, then the standard
! output is condidered.
! root - integer, input, optional.
! The id of the process printing the message; -1 acts as a wildcard.
! Default is psb_root_
!
!
!
! verbosity:
! <0: suppress all messages
! 0: normal
! >1: increased details
!
subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,global)
use psb_base_mod
use amg_c_prec_mod, amg_protect_name => amg_cfile_prec_memory_use
use amg_c_inner_mod
use amg_c_gs_solver
implicit none
! Arguments
class(amg_cprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
! Local variables
integer(psb_ipk_) :: ilev, nlev, ilmin, nswps
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np
logical :: is_symgs
character(len=20), parameter :: name='amg_file_prec_memory_use'
integer(psb_ipk_) :: iout_, root_, verbosity_
logical :: global_
character(1024) :: prefix_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
end if
if (iout_ < 0) iout_ = psb_out_unit
if (present(verbosity)) then
verbosity_ = verbosity
else
verbosity_ = 0
end if
if (verbosity_ < 0) goto 9998
ctxt = prec%ctxt
call psb_info(ctxt,me,np)
prefix_ = ""
if (verbosity_ == 0) then
if (present(prefix)) then
prefix_ = prefix
end if
else if (verbosity_ > 0) then
if (present(prefix)) then
write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': '
else
write(prefix_,'(a,i5,a)') 'Process ',me,': '
end if
end if
if (present(root)) then
root_ = root
else
root_ = psb_root_
end if
if (root_ == -1) root_ = me
if (allocated(prec%precv)) then
if (verbosity_ >=0) then
if (me == root_) then
write(iout_,*)
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage'
end if
nlev = size(prec%precv)
do ilev=1,nlev
call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, &
& iout=iout_,verbosity=verbosity_,prefix=trim(prefix_),global=global)
end do
else
write(iout_,*) trim(name), &
& ': Error: no base preconditioner available, something is wrong!'
info = -2
return
endif
end if
9998 continue
end subroutine amg_cfile_prec_memory_use

2
amgprec/impl/amg_cprecinit.F90
Unescape Escape View File

@ -98,6 +98,7 @@ subroutine amg_cprecinit(ctxt,prec,ptype,info)
use amg_c_diag_solver
use amg_c_ilu_solver
use amg_c_gs_solver
#if defined(HAVE_SLU_)
use amg_c_slu_solver
#endif
@ -152,7 +153,6 @@ subroutine amg_cprecinit(ctxt,prec,ptype,info)
if (info /= psb_success_) return
allocate(amg_c_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
call prec%precv(ilev_)%default()
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
nlev_ = 1
ilev_ = 1

67
amgprec/impl/amg_d_hierarchy_bld.f90 → amgprec/impl/amg_d_hierarchy_bld.F90
Unescape Escape View File

@ -507,6 +507,71 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
return
contains
#if ( __GNUC__ == 13 && __GNUC_MINOR__ == 3)
! gfortran 13.3.0 generates a strange error here with MOLD
! moving to SOURCE but only for this version, since it's heavier
subroutine save_smoothers(level,save1, save2,info)
type(amg_d_onelev_type), intent(inout) :: level
class(amg_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) call level%sm%clone_settings(save1,info)
if ((info == 0).and.allocated(level%sm2a)) then
allocate(save2, source=level%sm2a,stat=info)
if (info == 0) call level%sm2a%clone_settings(save2,info)
end if
return
end subroutine save_smoothers
subroutine restore_smoothers(level,save1, save2,info)
type(amg_d_onelev_type), intent(inout), target :: level
class(amg_d_base_smoother_type), allocatable, intent(inout) :: 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)
if (info == 0) call save1%clone_settings(level%sm,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) call save2%clone_settings(level%sm2a,info)
if (info == 0) level%sm2 => level%sm2a
else
if (allocated(level%sm)) level%sm2 => level%sm
end if
return
end subroutine restore_smoothers
#else
subroutine save_smoothers(level,save1, save2,info)
type(amg_d_onelev_type), intent(inout) :: level
class(amg_d_base_smoother_type), allocatable , intent(inout) :: save1, save2
@ -565,5 +630,5 @@ contains
return
end subroutine restore_smoothers
#endif
end subroutine amg_d_hierarchy_bld

4
amgprec/impl/amg_d_smoothers_bld.f90
Unescape Escape View File

@ -186,8 +186,8 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& ' but it has been changed to distributed.'
end if
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
case(amg_ilu_n_, amg_ilu_t_,amg_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= amg_ilu_n_) then
write(psb_err_unit,*) &
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
& amg_fact_names(coarse_solve_id)

36
amgprec/impl/amg_dcprecset.F90
Unescape Escape View File

@ -499,7 +499,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -515,7 +515,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -538,7 +538,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -546,21 +546,21 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#endif
case('ILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('ILUT')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('MILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
@ -575,7 +575,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -605,7 +605,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -643,7 +643,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -753,7 +753,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -768,7 +768,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -791,7 +791,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -799,21 +799,21 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#endif
case('ILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('ILUT')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('MILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
@ -828,7 +828,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -858,7 +858,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -896,7 +896,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)

2
amgprec/impl/amg_dfile_prec_descr.f90
Unescape Escape View File

@ -170,7 +170,7 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
call prec%precv(1)%sm%descr(info,iout=iout_,prefix=prefix)
nswps = prec%precv(1)%parms%sweeps_pre
end if
write(iout_,*) trim(prefix_), ' Number of sweeps : ',nswps
write(iout_,*) trim(prefix_), ' Number of sweeps/degree : ',nswps
write(iout_,*) trim(prefix_)
else if (nlev > 1) then

152
amgprec/impl/amg_dfile_prec_memory_use.f90
Unescape Escape View File

@ -0,0 +1,152 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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: amg_dfile_prec_memory_use.f90
!
!
! Subroutine: amg_file_prec_memory_use
! Version: real
!
! This routine prints a memory_useiption of the preconditioner to the standard
! output or to a file. It must be called after the preconditioner has been
! built by amg_precbld.
!
! Arguments:
! p - type(amg_Tprec_type), input.
! The preconditioner data structure to be printed out.
! info - integer, output.
! error code.
! iout - integer, input, optional.
! The id of the file where the preconditioner description
! will be printed. If iout is not present, then the standard
! output is condidered.
! root - integer, input, optional.
! The id of the process printing the message; -1 acts as a wildcard.
! Default is psb_root_
!
!
!
! verbosity:
! <0: suppress all messages
! 0: normal
! >1: increased details
!
subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,global)
use psb_base_mod
use amg_d_prec_mod, amg_protect_name => amg_dfile_prec_memory_use
use amg_d_inner_mod
use amg_d_gs_solver
implicit none
! Arguments
class(amg_dprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
! Local variables
integer(psb_ipk_) :: ilev, nlev, ilmin, nswps
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np
logical :: is_symgs
character(len=20), parameter :: name='amg_file_prec_memory_use'
integer(psb_ipk_) :: iout_, root_, verbosity_
logical :: global_
character(1024) :: prefix_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
end if
if (iout_ < 0) iout_ = psb_out_unit
if (present(verbosity)) then
verbosity_ = verbosity
else
verbosity_ = 0
end if
if (verbosity_ < 0) goto 9998
ctxt = prec%ctxt
call psb_info(ctxt,me,np)
prefix_ = ""
if (verbosity_ == 0) then
if (present(prefix)) then
prefix_ = prefix
end if
else if (verbosity_ > 0) then
if (present(prefix)) then
write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': '
else
write(prefix_,'(a,i5,a)') 'Process ',me,': '
end if
end if
if (present(root)) then
root_ = root
else
root_ = psb_root_
end if
if (root_ == -1) root_ = me
if (allocated(prec%precv)) then
if (verbosity_ >=0) then
if (me == root_) then
write(iout_,*)
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage'
end if
nlev = size(prec%precv)
do ilev=1,nlev
call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, &
& iout=iout_,verbosity=verbosity_,prefix=trim(prefix_),global=global)
end do
else
write(iout_,*) trim(name), &
& ': Error: no base preconditioner available, something is wrong!'
info = -2
return
endif
end if
9998 continue
end subroutine amg_dfile_prec_memory_use

11
amgprec/impl/amg_dprecinit.F90
Unescape Escape View File

@ -98,6 +98,8 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info)
use amg_d_diag_solver
use amg_d_ilu_solver
use amg_d_gs_solver
use amg_d_poly_smoother
#if defined(HAVE_UMF_)
use amg_d_umf_solver
#endif
@ -155,7 +157,14 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info)
if (info /= psb_success_) return
allocate(amg_d_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
call prec%precv(ilev_)%default()
case ('POLY')
nlev_ = 1
ilev_ = 1
allocate(prec%precv(nlev_),stat=info)
allocate(amg_d_poly_smoother_type :: prec%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
allocate(amg_d_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
call prec%precv(ilev_)%default()
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
nlev_ = 1
ilev_ = 1

67
amgprec/impl/amg_s_hierarchy_bld.f90 → amgprec/impl/amg_s_hierarchy_bld.F90
Unescape Escape View File

@ -507,6 +507,71 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
return
contains
#if ( __GNUC__ == 13 && __GNUC_MINOR__ == 3)
! gfortran 13.3.0 generates a strange error here with MOLD
! moving to SOURCE but only for this version, since it's heavier
subroutine save_smoothers(level,save1, save2,info)
type(amg_s_onelev_type), intent(inout) :: level
class(amg_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) call level%sm%clone_settings(save1,info)
if ((info == 0).and.allocated(level%sm2a)) then
allocate(save2, source=level%sm2a,stat=info)
if (info == 0) call level%sm2a%clone_settings(save2,info)
end if
return
end subroutine save_smoothers
subroutine restore_smoothers(level,save1, save2,info)
type(amg_s_onelev_type), intent(inout), target :: level
class(amg_s_base_smoother_type), allocatable, intent(inout) :: 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)
if (info == 0) call save1%clone_settings(level%sm,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) call save2%clone_settings(level%sm2a,info)
if (info == 0) level%sm2 => level%sm2a
else
if (allocated(level%sm)) level%sm2 => level%sm
end if
return
end subroutine restore_smoothers
#else
subroutine save_smoothers(level,save1, save2,info)
type(amg_s_onelev_type), intent(inout) :: level
class(amg_s_base_smoother_type), allocatable , intent(inout) :: save1, save2
@ -565,5 +630,5 @@ contains
return
end subroutine restore_smoothers
#endif
end subroutine amg_s_hierarchy_bld

4
amgprec/impl/amg_s_smoothers_bld.f90
Unescape Escape View File

@ -186,8 +186,8 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& ' but it has been changed to distributed.'
end if
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
case(amg_ilu_n_, amg_ilu_t_,amg_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= amg_ilu_n_) then
write(psb_err_unit,*) &
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
& amg_fact_names(coarse_solve_id)

36
amgprec/impl/amg_scprecset.F90
Unescape Escape View File

@ -485,7 +485,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -499,7 +499,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -522,7 +522,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -530,21 +530,21 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#endif
case('ILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('ILUT')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('MILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
@ -559,7 +559,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -582,7 +582,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -606,7 +606,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -714,7 +714,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -727,7 +727,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -750,7 +750,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -758,21 +758,21 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#endif
case('ILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('ILUT')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('MILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
@ -787,7 +787,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -810,7 +810,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -834,7 +834,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)

2
amgprec/impl/amg_sfile_prec_descr.f90
Unescape Escape View File

@ -170,7 +170,7 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
call prec%precv(1)%sm%descr(info,iout=iout_,prefix=prefix)
nswps = prec%precv(1)%parms%sweeps_pre
end if
write(iout_,*) trim(prefix_), ' Number of sweeps : ',nswps
write(iout_,*) trim(prefix_), ' Number of sweeps/degree : ',nswps
write(iout_,*) trim(prefix_)
else if (nlev > 1) then

152
amgprec/impl/amg_sfile_prec_memory_use.f90
Unescape Escape View File

@ -0,0 +1,152 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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: amg_dfile_prec_memory_use.f90
!
!
! Subroutine: amg_file_prec_memory_use
! Version: real
!
! This routine prints a memory_useiption of the preconditioner to the standard
! output or to a file. It must be called after the preconditioner has been
! built by amg_precbld.
!
! Arguments:
! p - type(amg_Tprec_type), input.
! The preconditioner data structure to be printed out.
! info - integer, output.
! error code.
! iout - integer, input, optional.
! The id of the file where the preconditioner description
! will be printed. If iout is not present, then the standard
! output is condidered.
! root - integer, input, optional.
! The id of the process printing the message; -1 acts as a wildcard.
! Default is psb_root_
!
!
!
! verbosity:
! <0: suppress all messages
! 0: normal
! >1: increased details
!
subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,global)
use psb_base_mod
use amg_s_prec_mod, amg_protect_name => amg_sfile_prec_memory_use
use amg_s_inner_mod
use amg_s_gs_solver
implicit none
! Arguments
class(amg_sprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
! Local variables
integer(psb_ipk_) :: ilev, nlev, ilmin, nswps
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np
logical :: is_symgs
character(len=20), parameter :: name='amg_file_prec_memory_use'
integer(psb_ipk_) :: iout_, root_, verbosity_
logical :: global_
character(1024) :: prefix_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
end if
if (iout_ < 0) iout_ = psb_out_unit
if (present(verbosity)) then
verbosity_ = verbosity
else
verbosity_ = 0
end if
if (verbosity_ < 0) goto 9998
ctxt = prec%ctxt
call psb_info(ctxt,me,np)
prefix_ = ""
if (verbosity_ == 0) then
if (present(prefix)) then
prefix_ = prefix
end if
else if (verbosity_ > 0) then
if (present(prefix)) then
write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': '
else
write(prefix_,'(a,i5,a)') 'Process ',me,': '
end if
end if
if (present(root)) then
root_ = root
else
root_ = psb_root_
end if
if (root_ == -1) root_ = me
if (allocated(prec%precv)) then
if (verbosity_ >=0) then
if (me == root_) then
write(iout_,*)
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage'
end if
nlev = size(prec%precv)
do ilev=1,nlev
call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, &
& iout=iout_,verbosity=verbosity_,prefix=trim(prefix_),global=global)
end do
else
write(iout_,*) trim(name), &
& ': Error: no base preconditioner available, something is wrong!'
info = -2
return
endif
end if
9998 continue
end subroutine amg_sfile_prec_memory_use

11
amgprec/impl/amg_sprecinit.F90
Unescape Escape View File

@ -98,6 +98,8 @@ subroutine amg_sprecinit(ctxt,prec,ptype,info)
use amg_s_diag_solver
use amg_s_ilu_solver
use amg_s_gs_solver
use amg_s_poly_smoother
#if defined(HAVE_SLU_)
use amg_s_slu_solver
#endif
@ -152,7 +154,14 @@ subroutine amg_sprecinit(ctxt,prec,ptype,info)
if (info /= psb_success_) return
allocate(amg_s_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
call prec%precv(ilev_)%default()
case ('POLY')
nlev_ = 1
ilev_ = 1
allocate(prec%precv(nlev_),stat=info)
allocate(amg_s_poly_smoother_type :: prec%precv(ilev_)%sm, stat=info)
if (info /= psb_success_) return
allocate(amg_s_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
call prec%precv(ilev_)%default()
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
nlev_ = 1
ilev_ = 1

67
amgprec/impl/amg_z_hierarchy_bld.f90 → amgprec/impl/amg_z_hierarchy_bld.F90
Unescape Escape View File

@ -507,6 +507,71 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
return
contains
#if ( __GNUC__ == 13 && __GNUC_MINOR__ == 3)
! gfortran 13.3.0 generates a strange error here with MOLD
! moving to SOURCE but only for this version, since it's heavier
subroutine save_smoothers(level,save1, save2,info)
type(amg_z_onelev_type), intent(inout) :: level
class(amg_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) call level%sm%clone_settings(save1,info)
if ((info == 0).and.allocated(level%sm2a)) then
allocate(save2, source=level%sm2a,stat=info)
if (info == 0) call level%sm2a%clone_settings(save2,info)
end if
return
end subroutine save_smoothers
subroutine restore_smoothers(level,save1, save2,info)
type(amg_z_onelev_type), intent(inout), target :: level
class(amg_z_base_smoother_type), allocatable, intent(inout) :: 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)
if (info == 0) call save1%clone_settings(level%sm,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) call save2%clone_settings(level%sm2a,info)
if (info == 0) level%sm2 => level%sm2a
else
if (allocated(level%sm)) level%sm2 => level%sm
end if
return
end subroutine restore_smoothers
#else
subroutine save_smoothers(level,save1, save2,info)
type(amg_z_onelev_type), intent(inout) :: level
class(amg_z_base_smoother_type), allocatable , intent(inout) :: save1, save2
@ -565,5 +630,5 @@ contains
return
end subroutine restore_smoothers
#endif
end subroutine amg_z_hierarchy_bld

4
amgprec/impl/amg_z_smoothers_bld.f90
Unescape Escape View File

@ -186,8 +186,8 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
& ' but it has been changed to distributed.'
end if
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
case(amg_ilu_n_, amg_ilu_t_,amg_milu_n_)
if (prec%precv(iszv)%sm%sv%get_id() /= amg_ilu_n_) then
write(psb_err_unit,*) &
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
& amg_fact_names(coarse_solve_id)

36
amgprec/impl/amg_zcprecset.F90
Unescape Escape View File

@ -499,7 +499,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -515,7 +515,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -538,7 +538,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -546,21 +546,21 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#endif
case('ILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('ILUT')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('MILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
@ -575,7 +575,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -605,7 +605,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -643,7 +643,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -753,7 +753,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -768,7 +768,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#elif defined(HAVE_MUMPS_)
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
#else
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
#endif
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
@ -791,7 +791,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -799,21 +799,21 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
#endif
case('ILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('ILUT')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
case('MILU')
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_repl_mat_)
@ -828,7 +828,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -858,7 +858,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)
@ -896,7 +896,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
#else
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
if (hier_asb) &
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
& amg_distr_mat_)

2
amgprec/impl/amg_zfile_prec_descr.f90
Unescape Escape View File

@ -170,7 +170,7 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
call prec%precv(1)%sm%descr(info,iout=iout_,prefix=prefix)
nswps = prec%precv(1)%parms%sweeps_pre
end if
write(iout_,*) trim(prefix_), ' Number of sweeps : ',nswps
write(iout_,*) trim(prefix_), ' Number of sweeps/degree : ',nswps
write(iout_,*) trim(prefix_)
else if (nlev > 1) then

152
amgprec/impl/amg_zfile_prec_memory_use.f90
Unescape Escape View File

@ -0,0 +1,152 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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: amg_dfile_prec_memory_use.f90
!
!
! Subroutine: amg_file_prec_memory_use
! Version: complex
!
! This routine prints a memory_useiption of the preconditioner to the standard
! output or to a file. It must be called after the preconditioner has been
! built by amg_precbld.
!
! Arguments:
! p - type(amg_Tprec_type), input.
! The preconditioner data structure to be printed out.
! info - integer, output.
! error code.
! iout - integer, input, optional.
! The id of the file where the preconditioner description
! will be printed. If iout is not present, then the standard
! output is condidered.
! root - integer, input, optional.
! The id of the process printing the message; -1 acts as a wildcard.
! Default is psb_root_
!
!
!
! verbosity:
! <0: suppress all messages
! 0: normal
! >1: increased details
!
subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,global)
use psb_base_mod
use amg_z_prec_mod, amg_protect_name => amg_zfile_prec_memory_use
use amg_z_inner_mod
use amg_z_gs_solver
implicit none
! Arguments
class(amg_zprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
! Local variables
integer(psb_ipk_) :: ilev, nlev, ilmin, nswps
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me, np
logical :: is_symgs
character(len=20), parameter :: name='amg_file_prec_memory_use'
integer(psb_ipk_) :: iout_, root_, verbosity_
logical :: global_
character(1024) :: prefix_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
end if
if (iout_ < 0) iout_ = psb_out_unit
if (present(verbosity)) then
verbosity_ = verbosity
else
verbosity_ = 0
end if
if (verbosity_ < 0) goto 9998
ctxt = prec%ctxt
call psb_info(ctxt,me,np)
prefix_ = ""
if (verbosity_ == 0) then
if (present(prefix)) then
prefix_ = prefix
end if
else if (verbosity_ > 0) then
if (present(prefix)) then
write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': '
else
write(prefix_,'(a,i5,a)') 'Process ',me,': '
end if
end if
if (present(root)) then
root_ = root
else
root_ = psb_root_
end if
if (root_ == -1) root_ = me
if (allocated(prec%precv)) then
if (verbosity_ >=0) then
if (me == root_) then
write(iout_,*)
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage'
end if
nlev = size(prec%precv)
do ilev=1,nlev
call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, &
& iout=iout_,verbosity=verbosity_,prefix=trim(prefix_),global=global)
end do
else
write(iout_,*) trim(name), &
& ': Error: no base preconditioner available, something is wrong!'
info = -2
return
endif
end if
9998 continue
end subroutine amg_zfile_prec_memory_use

2
amgprec/impl/amg_zprecinit.F90
Unescape Escape View File

@ -98,6 +98,7 @@ subroutine amg_zprecinit(ctxt,prec,ptype,info)
use amg_z_diag_solver
use amg_z_ilu_solver
use amg_z_gs_solver
#if defined(HAVE_UMF_)
use amg_z_umf_solver
#endif
@ -155,7 +156,6 @@ subroutine amg_zprecinit(ctxt,prec,ptype,info)
if (info /= psb_success_) return
allocate(amg_z_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
call prec%precv(ilev_)%default()
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
nlev_ = 1
ilev_ = 1

4
amgprec/impl/level/Makefile
Unescape Escape View File

@ -15,6 +15,7 @@ amg_c_base_onelev_csetc.o \
amg_c_base_onelev_cseti.o \
amg_c_base_onelev_csetr.o \
amg_c_base_onelev_descr.o \
amg_c_base_onelev_memory_use.o \
amg_c_base_onelev_dump.o \
amg_c_base_onelev_free.o \
amg_c_base_onelev_free_smoothers.o \
@ -31,6 +32,7 @@ amg_d_base_onelev_csetc.o \
amg_d_base_onelev_cseti.o \
amg_d_base_onelev_csetr.o \
amg_d_base_onelev_descr.o \
amg_d_base_onelev_memory_use.o \
amg_d_base_onelev_dump.o \
amg_d_base_onelev_free.o \
amg_d_base_onelev_free_smoothers.o \
@ -47,6 +49,7 @@ amg_s_base_onelev_csetc.o \
amg_s_base_onelev_cseti.o \
amg_s_base_onelev_csetr.o \
amg_s_base_onelev_descr.o \
amg_s_base_onelev_memory_use.o \
amg_s_base_onelev_dump.o \
amg_s_base_onelev_free.o \
amg_s_base_onelev_free_smoothers.o \
@ -63,6 +66,7 @@ amg_z_base_onelev_csetc.o \
amg_z_base_onelev_cseti.o \
amg_z_base_onelev_csetr.o \
amg_z_base_onelev_descr.o \
amg_z_base_onelev_memory_use.o \
amg_z_base_onelev_dump.o \
amg_z_base_onelev_free.o \
amg_z_base_onelev_free_smoothers.o \

10
amgprec/impl/level/amg_c_base_onelev_csetc.F90
Unescape Escape View File

@ -43,7 +43,6 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
use amg_c_dec_aggregator_mod
use amg_c_symdec_aggregator_mod
#if !defined(SERIAL_MPI)
#endif
use amg_c_jac_smoother
use amg_c_as_smoother
use amg_c_diag_solver
@ -190,16 +189,11 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('NONE','NOPREC','FACT_NONE')
call lv%set(amg_c_id_solver_mold,info,pos=pos)
case ('DIAG')
case ('DIAG','JACOBI')
call lv%set(amg_c_diag_solver_mold,info,pos=pos)
case ('JACOBI')
call lv%set(amg_c_jac_solver_mold,info,pos=pos)
case ('L1-DIAG')
case ('L1-DIAG','L1-JACOBI')
call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
case ('L1-JACOBI')
call lv%set(amg_c_l1_jac_solver_mold,info,pos=pos)
case ('GS','FGS','FWGS')
call lv%set(amg_c_gs_solver_mold,info,pos=pos)

2
amgprec/impl/level/amg_c_base_onelev_cseti.F90
Unescape Escape View File

@ -164,7 +164,7 @@ subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
case (amg_bwgs_)
call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
case (psb_ilu_n_,psb_milu_n_,psb_ilu_t_)
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
if (info == 0) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then

150
amgprec/impl/level/amg_c_base_onelev_memory_use.f90
Unescape Escape View File

@ -0,0 +1,150 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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.
!
!
!
!
! verbosity:
! <0: suppress all messages
! 0: normal
! >1: increased details
!
subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
use psb_base_mod
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_memory_use
Implicit None
! Arguments
class(amg_c_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
character(len=*), intent(in), optional :: prefix
integer(psb_ipk_), intent(in), optional :: verbosity
logical, intent(in), optional :: global
! Local variables
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: err_act ,me, np
character(len=20), parameter :: name='amg_c_base_onelev_memory_use'
integer(psb_ipk_) :: iout_, verbosity_
logical :: coarse, global_
character(1024) :: prefix_
integer(psb_epk_), allocatable :: sz(:)
call psb_erractionsave(err_act)
ctxt = lv%base_desc%get_ctxt()
call psb_info(ctxt,me,np)
coarse = (il==nl)
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
end if
if (present(verbosity)) then
verbosity_ = verbosity
else
verbosity_ = 0
end if
if (verbosity_ < 0) goto 9998
if (present(global)) then
global_ = global
else
global_ = .true.
end if
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
if (global_) then
allocate(sz(6))
sz(:) = 0
sz(1) = lv%base_a%sizeof()
sz(2) = lv%base_desc%sizeof()
if (il >1) sz(3) = lv%linmap%sizeof()
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
call psb_sum(ctxt,sz)
if (me == 0) then
if (coarse) then
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
else
write(iout_,*) trim(prefix_), ' Level ',il
end if
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
end if
else
if ((me == 0).or.(verbosity_>0)) then
if (coarse) then
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
else
write(iout_,*) trim(prefix_), ' Level ',il
end if
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
end if
endif
9998 continue
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_c_base_onelev_memory_use

15
amgprec/impl/level/amg_d_base_onelev_csetc.F90
Unescape Escape View File

@ -44,7 +44,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
use amg_d_symdec_aggregator_mod
#if !defined(SERIAL_MPI)
use amg_d_parmatch_aggregator_mod
#endif
use amg_d_poly_smoother
use amg_d_jac_smoother
use amg_d_as_smoother
use amg_d_diag_solver
@ -97,6 +97,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
type(amg_d_ainv_solver_type) :: amg_d_ainv_solver_mold
type(amg_d_invk_solver_type) :: amg_d_invk_solver_mold
type(amg_d_invt_solver_type) :: amg_d_invt_solver_mold
type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold
#if defined(HAVE_UMF_)
type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold
#endif
@ -158,6 +159,9 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
call lv%set(amg_d_as_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
case ('POLY')
call lv%set(amg_d_poly_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
case ('GS','FWGS')
call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
@ -203,16 +207,11 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('NONE','NOPREC','FACT_NONE')
call lv%set(amg_d_id_solver_mold,info,pos=pos)
case ('DIAG')
case ('DIAG','JACOBI')
call lv%set(amg_d_diag_solver_mold,info,pos=pos)
case ('JACOBI')
call lv%set(amg_d_jac_solver_mold,info,pos=pos)
case ('L1-DIAG')
case ('L1-DIAG','L1-JACOBI')
call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
case ('L1-JACOBI')
call lv%set(amg_d_l1_jac_solver_mold,info,pos=pos)
case ('GS','FGS','FWGS')
call lv%set(amg_d_gs_solver_mold,info,pos=pos)

2
amgprec/impl/level/amg_d_base_onelev_cseti.F90
Unescape Escape View File

@ -177,7 +177,7 @@ subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
case (amg_bwgs_)
call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
case (psb_ilu_n_,psb_milu_n_,psb_ilu_t_)
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
if (info == 0) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then

150
amgprec/impl/level/amg_d_base_onelev_memory_use.f90
Unescape Escape View File

@ -0,0 +1,150 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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.
!
!
!
!
! verbosity:
! <0: suppress all messages
! 0: normal
! >1: increased details
!
subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
use psb_base_mod
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_memory_use
Implicit None
! Arguments
class(amg_d_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
character(len=*), intent(in), optional :: prefix
integer(psb_ipk_), intent(in), optional :: verbosity
logical, intent(in), optional :: global
! Local variables
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: err_act ,me, np
character(len=20), parameter :: name='amg_d_base_onelev_memory_use'
integer(psb_ipk_) :: iout_, verbosity_
logical :: coarse, global_
character(1024) :: prefix_
integer(psb_epk_), allocatable :: sz(:)
call psb_erractionsave(err_act)
ctxt = lv%base_desc%get_ctxt()
call psb_info(ctxt,me,np)
coarse = (il==nl)
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
end if
if (present(verbosity)) then
verbosity_ = verbosity
else
verbosity_ = 0
end if
if (verbosity_ < 0) goto 9998
if (present(global)) then
global_ = global
else
global_ = .true.
end if
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
if (global_) then
allocate(sz(6))
sz(:) = 0
sz(1) = lv%base_a%sizeof()
sz(2) = lv%base_desc%sizeof()
if (il >1) sz(3) = lv%linmap%sizeof()
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
call psb_sum(ctxt,sz)
if (me == 0) then
if (coarse) then
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
else
write(iout_,*) trim(prefix_), ' Level ',il
end if
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
end if
else
if ((me == 0).or.(verbosity_>0)) then
if (coarse) then
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
else
write(iout_,*) trim(prefix_), ' Level ',il
end if
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
end if
endif
9998 continue
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_base_onelev_memory_use

15
amgprec/impl/level/amg_s_base_onelev_csetc.F90
Unescape Escape View File

@ -44,7 +44,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
use amg_s_symdec_aggregator_mod
#if !defined(SERIAL_MPI)
use amg_s_parmatch_aggregator_mod
#endif
use amg_s_poly_smoother
use amg_s_jac_smoother
use amg_s_as_smoother
use amg_s_diag_solver
@ -91,6 +91,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
type(amg_s_ainv_solver_type) :: amg_s_ainv_solver_mold
type(amg_s_invk_solver_type) :: amg_s_invk_solver_mold
type(amg_s_invt_solver_type) :: amg_s_invt_solver_mold
type(amg_s_poly_smoother_type) :: amg_s_poly_smoother_mold
#if defined(HAVE_SLU_)
type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold
#endif
@ -146,6 +147,9 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
call lv%set(amg_s_as_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
case ('POLY')
call lv%set(amg_s_poly_smoother_mold,info,pos=pos)
if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
case ('GS','FWGS')
call lv%set(amg_s_jac_smoother_mold,info,pos='pre')
if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre')
@ -191,16 +195,11 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('NONE','NOPREC','FACT_NONE')
call lv%set(amg_s_id_solver_mold,info,pos=pos)
case ('DIAG')
case ('DIAG','JACOBI')
call lv%set(amg_s_diag_solver_mold,info,pos=pos)
case ('JACOBI')
call lv%set(amg_s_jac_solver_mold,info,pos=pos)
case ('L1-DIAG')
case ('L1-DIAG','L1-JACOBI')
call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
case ('L1-JACOBI')
call lv%set(amg_s_l1_jac_solver_mold,info,pos=pos)
case ('GS','FGS','FWGS')
call lv%set(amg_s_gs_solver_mold,info,pos=pos)

2
amgprec/impl/level/amg_s_base_onelev_cseti.F90
Unescape Escape View File

@ -165,7 +165,7 @@ subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx)
case (amg_bwgs_)
call lv%set(amg_s_bwgs_solver_mold,info,pos=pos)
case (psb_ilu_n_,psb_milu_n_,psb_ilu_t_)
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
if (info == 0) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then

150
amgprec/impl/level/amg_s_base_onelev_memory_use.f90
Unescape Escape View File

@ -0,0 +1,150 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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.
!
!
!
!
! verbosity:
! <0: suppress all messages
! 0: normal
! >1: increased details
!
subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
use psb_base_mod
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_memory_use
Implicit None
! Arguments
class(amg_s_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
character(len=*), intent(in), optional :: prefix
integer(psb_ipk_), intent(in), optional :: verbosity
logical, intent(in), optional :: global
! Local variables
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: err_act ,me, np
character(len=20), parameter :: name='amg_s_base_onelev_memory_use'
integer(psb_ipk_) :: iout_, verbosity_
logical :: coarse, global_
character(1024) :: prefix_
integer(psb_epk_), allocatable :: sz(:)
call psb_erractionsave(err_act)
ctxt = lv%base_desc%get_ctxt()
call psb_info(ctxt,me,np)
coarse = (il==nl)
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
end if
if (present(verbosity)) then
verbosity_ = verbosity
else
verbosity_ = 0
end if
if (verbosity_ < 0) goto 9998
if (present(global)) then
global_ = global
else
global_ = .true.
end if
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
if (global_) then
allocate(sz(6))
sz(:) = 0
sz(1) = lv%base_a%sizeof()
sz(2) = lv%base_desc%sizeof()
if (il >1) sz(3) = lv%linmap%sizeof()
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
call psb_sum(ctxt,sz)
if (me == 0) then
if (coarse) then
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
else
write(iout_,*) trim(prefix_), ' Level ',il
end if
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
end if
else
if ((me == 0).or.(verbosity_>0)) then
if (coarse) then
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
else
write(iout_,*) trim(prefix_), ' Level ',il
end if
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
end if
endif
9998 continue
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_s_base_onelev_memory_use

10
amgprec/impl/level/amg_z_base_onelev_csetc.F90
Unescape Escape View File

@ -43,7 +43,6 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
use amg_z_dec_aggregator_mod
use amg_z_symdec_aggregator_mod
#if !defined(SERIAL_MPI)
#endif
use amg_z_jac_smoother
use amg_z_as_smoother
use amg_z_diag_solver
@ -202,16 +201,11 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
case ('NONE','NOPREC','FACT_NONE')
call lv%set(amg_z_id_solver_mold,info,pos=pos)
case ('DIAG')
case ('DIAG','JACOBI')
call lv%set(amg_z_diag_solver_mold,info,pos=pos)
case ('JACOBI')
call lv%set(amg_z_jac_solver_mold,info,pos=pos)
case ('L1-DIAG')
case ('L1-DIAG','L1-JACOBI')
call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos)
case ('L1-JACOBI')
call lv%set(amg_z_l1_jac_solver_mold,info,pos=pos)
case ('GS','FGS','FWGS')
call lv%set(amg_z_gs_solver_mold,info,pos=pos)

2
amgprec/impl/level/amg_z_base_onelev_cseti.F90
Unescape Escape View File

@ -176,7 +176,7 @@ subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx)
case (amg_bwgs_)
call lv%set(amg_z_bwgs_solver_mold,info,pos=pos)
case (psb_ilu_n_,psb_milu_n_,psb_ilu_t_)
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
if (info == 0) then
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then

150
amgprec/impl/level/amg_z_base_onelev_memory_use.f90
Unescape Escape View File

@ -0,0 +1,150 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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.
!
!
!
!
! verbosity:
! <0: suppress all messages
! 0: normal
! >1: increased details
!
subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
use psb_base_mod
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_memory_use
Implicit None
! Arguments
class(amg_z_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
character(len=*), intent(in), optional :: prefix
integer(psb_ipk_), intent(in), optional :: verbosity
logical, intent(in), optional :: global
! Local variables
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: err_act ,me, np
character(len=20), parameter :: name='amg_z_base_onelev_memory_use'
integer(psb_ipk_) :: iout_, verbosity_
logical :: coarse, global_
character(1024) :: prefix_
integer(psb_epk_), allocatable :: sz(:)
call psb_erractionsave(err_act)
ctxt = lv%base_desc%get_ctxt()
call psb_info(ctxt,me,np)
coarse = (il==nl)
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
end if
if (present(verbosity)) then
verbosity_ = verbosity
else
verbosity_ = 0
end if
if (verbosity_ < 0) goto 9998
if (present(global)) then
global_ = global
else
global_ = .true.
end if
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
if (global_) then
allocate(sz(6))
sz(:) = 0
sz(1) = lv%base_a%sizeof()
sz(2) = lv%base_desc%sizeof()
if (il >1) sz(3) = lv%linmap%sizeof()
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
call psb_sum(ctxt,sz)
if (me == 0) then
if (coarse) then
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
else
write(iout_,*) trim(prefix_), ' Level ',il
end if
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
end if
else
if ((me == 0).or.(verbosity_>0)) then
if (coarse) then
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
else
write(iout_,*) trim(prefix_), ' Level ',il
end if
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
end if
endif
9998 continue
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_z_base_onelev_memory_use

22
amgprec/impl/smoother/Makefile
Unescape Escape View File

@ -97,6 +97,17 @@ amg_d_jac_smoother_csetr.o \
amg_d_l1_jac_smoother_bld.o \
amg_d_l1_jac_smoother_descr.o \
amg_d_l1_jac_smoother_clone.o \
amg_d_poly_smoother_apply_vect.o \
amg_d_poly_smoother_bld.o \
amg_d_poly_smoother_cnv.o \
amg_d_poly_smoother_clone.o \
amg_d_poly_smoother_clone_settings.o \
amg_d_poly_smoother_clear_data.o \
amg_d_poly_smoother_descr.o \
amg_d_poly_smoother_dmp.o \
amg_d_poly_smoother_csetc.o \
amg_d_poly_smoother_cseti.o \
amg_d_poly_smoother_csetr.o \
amg_s_as_smoother_apply.o \
amg_s_as_smoother_apply_vect.o \
amg_s_as_smoother_bld.o \
@ -142,6 +153,17 @@ amg_s_jac_smoother_csetr.o \
amg_s_l1_jac_smoother_bld.o \
amg_s_l1_jac_smoother_descr.o \
amg_s_l1_jac_smoother_clone.o \
amg_s_poly_smoother_apply_vect.o \
amg_s_poly_smoother_bld.o \
amg_s_poly_smoother_cnv.o \
amg_s_poly_smoother_clone.o \
amg_s_poly_smoother_clone_settings.o \
amg_s_poly_smoother_clear_data.o \
amg_s_poly_smoother_descr.o \
amg_s_poly_smoother_dmp.o \
amg_s_poly_smoother_csetc.o \
amg_s_poly_smoother_cseti.o \
amg_s_poly_smoother_csetr.o \
amg_z_as_smoother_apply.o \
amg_z_as_smoother_apply_vect.o \
amg_z_as_smoother_bld.o \

2
amgprec/impl/smoother/amg_c_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -175,7 +175,7 @@ subroutine amg_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if (info /= psb_success_) exit
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
call psb_geaxpby(cone,x,czero,r,r,desc_data,info)
call psb_geaxpby(cone,x,czero,r,desc_data,info)
call psb_spmm(-cone,sm%pa,ty,cone,r,desc_data,info)
res = psb_genrm2(r,desc_data,info)
if( sm%printres ) then

2
amgprec/impl/smoother/amg_d_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -175,7 +175,7 @@ subroutine amg_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if (info /= psb_success_) exit
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
call psb_geaxpby(done,x,dzero,r,r,desc_data,info)
call psb_geaxpby(done,x,dzero,r,desc_data,info)
call psb_spmm(-done,sm%pa,ty,done,r,desc_data,info)
res = psb_genrm2(r,desc_data,info)
if( sm%printres ) then

281
amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90
Unescape Escape View File

@ -0,0 +1,281 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use amg_d_diag_solver
use psb_base_krylov_conv_mod, only : log_conv
use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_d_poly_smoother_type), intent(inout) :: sm
type(psb_d_vect_type),intent(inout) :: x
type(psb_d_vect_type),intent(inout) :: y
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps! this is ignored here, the polynomial degree dictates the value
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
! Timers
logical, parameter :: do_timings=.true.
integer(psb_ipk_), save :: poly_1=-1, poly_2=-1, poly_3=-1
integer(psb_ipk_), save :: poly_mv=-1, poly_sv=-1, poly_vect=-1
!
integer(psb_ipk_) :: n_row,n_col
type(psb_d_vect_type) :: tx, ty, tz, r
real(psb_dpk_), pointer :: aux(:)
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, i, err_act
character :: trans_, init_
real(psb_dpk_) :: res, resdenum
character(len=20) :: name='d_poly_smoother_apply_v'
call psb_erractionsave(err_act)
info = psb_success_
ctxt = desc_data%get_context()
call psb_info(ctxt,me,np)
if (present(init)) then
init_ = psb_toupper(init)
else
init_='Z'
end if
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
if (.not.allocated(sm%sv)) then
info = 1121
call psb_errpush(info,name)
goto 9999
end if
if ((do_timings).and.(poly_1==-1)) &
& poly_1 = psb_get_timer_idx("POLY: Chebychev4")
if ((do_timings).and.(poly_2==-1)) &
& poly_2 = psb_get_timer_idx("POLY: OptChebychev4")
if ((do_timings).and.(poly_3==-1)) &
& poly_3 = psb_get_timer_idx("POLY: OptChebychev1")
if ((do_timings).and.(poly_mv==-1)) &
& poly_mv = psb_get_timer_idx("POLY: spMV")
if ((do_timings).and.(poly_vect==-1)) &
& poly_vect = psb_get_timer_idx("POLY: Vectors")
if ((do_timings).and.(poly_sv==-1)) &
& poly_sv = psb_get_timer_idx("POLY: solver")
n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols()
if (4*n_col <= size(work)) then
aux => work(:)
else
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
endif
if (size(wv) < 4) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2), tz => wv(3), r => wv(4))
call psb_geaxpby(done,x,dzero,r,desc_data,info)
call tx%zero()
call ty%zero()
call tz%zero()
select case(sm%variant)
case(amg_poly_lottes_)
if (do_timings) call psb_tic(poly_1)
block
real(psb_dpk_) :: cz, cr
! b == x
! x == tx
!
do i=1, sm%pdegree-1
! B r_{k-1}
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') ! ty = M^{-1} r
if (do_timings) call psb_toc(poly_sv)
cz = (2*i*done-3)/(2*i*done+done)
cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz(cr,cz,done,done,ty,tz,tx,desc_data,info) ! zk = cz * zk-1 + cr * rk-1
if (do_timings) call psb_toc(poly_vect)
if (do_timings) call psb_tic(poly_mv)
call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_)
if (do_timings) call psb_toc(poly_mv)
end do
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') ! ty = M^{-1} r
if (do_timings) call psb_toc(poly_sv)
cz = (2*sm%pdegree*done-3)/(2*sm%pdegree*done+done)
cr = (8*sm%pdegree*done-4)/((2*sm%pdegree*done+done)*sm%rho_ba)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz(cr,cz,done,done,ty,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
end block
if (do_timings) call psb_toc(poly_1)
case(amg_poly_lottes_beta_)
if (do_timings) call psb_tic(poly_2)
block
real(psb_dpk_) :: cz, cr
! b == x
! x == tx
!
if (allocated(sm%poly_beta)) then
if (size(sm%poly_beta) /= sm%pdegree) deallocate(sm%poly_beta)
end if
if (.not.allocated(sm%poly_beta)) then
call psb_realloc(sm%pdegree,sm%poly_beta,info)
sm%poly_beta(1:sm%pdegree) = amg_d_poly_beta_mat(1:sm%pdegree,sm%pdegree)
end if
do i=1, sm%pdegree-1
! B r_{k-1}
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z')
if (do_timings) call psb_toc(poly_sv)
cz = (2*i*done-3)/(2*i*done+done)
cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz(cr,cz,sm%poly_beta(i),done,ty,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
if (do_timings) call psb_tic(poly_mv)
call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_)
if (do_timings) call psb_toc(poly_mv)
end do
call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z')
cz = (2*sm%pdegree*done-3)/(2*sm%pdegree*done+done)
cr = (8*sm%pdegree*done-4)/((2*sm%pdegree*done+done)*sm%rho_ba)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz(cr,cz,sm%poly_beta(sm%pdegree),done,ty,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
end block
if (do_timings) call psb_toc(poly_2)
case(amg_poly_new_)
if (do_timings) call psb_tic(poly_3)
block
real(psb_dpk_) :: sigma, theta, delta, rho_old, rho
! b == x
! x == tx
!
theta = (done+sm%cf_a)/2
delta = (done-sm%cf_a)/2
sigma = theta/delta
rho_old = done/sigma
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z')
if (do_timings) call psb_toc(poly_sv)
call psb_geaxpby((done/sm%rho_ba),ty,dzero,r,desc_data,info)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz((done/theta),dzero,done,done,r,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
! tz == d
do i=1, sm%pdegree-1
!
!
! r_{k-1} = r_k - (1/rho(BA)) B A d_k
if (do_timings) call psb_tic(poly_mv)
call psb_spmm(done,sm%pa,tz,dzero,ty,desc_data,info,work=aux,trans=trans_)
if (do_timings) call psb_toc(poly_mv)
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(-(done/sm%rho_ba),ty,done,r,desc_data,trans_,aux,wv(5:),info,init='Z')
if (do_timings) call psb_toc(poly_sv)
!
! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1}
rho = done/(2*sigma - rho_old)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz((2*rho/delta),(rho*rho_old),done,done,r,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
rho_old = rho
end do
end block
if (do_timings) call psb_toc(poly_3)
case default
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='wrong polynomial variant')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,tx,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='polynomial smoother')
goto 9999
end if
end associate
if (.not.(4*n_col <= size(work))) then
deallocate(aux)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_apply_vect

179
amgprec/impl/smoother/amg_d_poly_smoother_bld.f90
Unescape Escape View File

@ -0,0 +1,179 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
use psb_base_mod
use amg_d_diag_solver
use amg_d_l1_diag_solver
use amg_d_poly_coeff_mod
use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_bld
Implicit None
! Arguments
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_d_poly_smoother_type), intent(inout) :: sm
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
! Local variables
type(psb_dspmat_type) :: tmpa
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
type(psb_ctxt_type) :: ctxt
real(psb_dpk_), allocatable :: da(:), dsv(:)
integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level
character(len=20) :: name='d_poly_smoother_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
n_row = desc_a%get_local_rows()
n_col = desc_a%get_local_cols()
nrow_a = a%get_nrows()
nztota = a%get_nzeros()
select case(sm%variant)
case(amg_poly_lottes_)
! do nothing
case(amg_poly_lottes_beta_)
if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then
call psb_realloc(sm%pdegree,sm%poly_beta,info)
sm%poly_beta(1:sm%pdegree) = amg_d_poly_beta_mat(1:sm%pdegree,sm%pdegree)
else
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid sm%degree for poly_beta')
goto 9999
end if
case(amg_poly_new_)
if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then
!Ok
sm%cf_a = amg_d_poly_a_vect(sm%pdegree)
else
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid sm%degree for poly_a')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid sm%variant')
goto 9999
end select
sm%pa => a
if (.not.allocated(sm%sv)) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='unallocated sm%sv')
goto 9999
end if
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='sv%build')
goto 9999
end if
!!$ if (.false.) then
!!$ select type(ssv => sm%sv)
!!$ class is(amg_d_l1_diag_solver_type)
!!$ da = a%arwsum(info)
!!$ dsv = ssv%dv%get_vect()
!!$ sm%rho_ba = maxval(da(1:n_row)*dsv(1:n_row))
!!$ class default
!!$ write(0,*) 'PolySmoother BUILD: only L1-Jacobi/L1-DIAG for now ',ssv%get_fmt()
!!$ sm%rho_ba = done
!!$ end select
!!$ else
if (sm%rho_ba <= dzero) then
select case(sm%rho_estimate)
case(amg_poly_rho_est_power_)
block
type(psb_d_vect_type) :: tq, tt, tz,wv(2)
real(psb_dpk_) :: znrm, lambda
real(psb_dpk_),allocatable :: work(:)
integer(psb_ipk_) :: i, n_cols
n_cols = desc_a%get_local_cols()
allocate(work(4*n_cols))
call psb_geasb(tz,desc_a,info,mold=vmold,scratch=.true.)
call psb_geasb(tt,desc_a,info,mold=vmold,scratch=.true.)
call psb_geasb(wv(1),desc_a,info,mold=vmold,scratch=.true.)
call psb_geasb(wv(2),desc_a,info,mold=vmold,scratch=.true.)
call psb_geall(tq,desc_a,info)
call tq%set(done)
call psb_geasb(tq,desc_a,info,mold=vmold)
call psb_spmm(done,a,tq,dzero,tt,desc_a,info) !
call sm%sv%apply_v(done,tt,dzero,tz,desc_a,'NoTrans',work,wv,info) ! z_{k+1} = BA q_k
do i=1,sm%rho_estimate_iterations
znrm = psb_genrm2(tz,desc_a,info) ! znrm = |z_k|_2
call psb_geaxpby((done/znrm),tz,dzero,tq,desc_a,info) ! q_k = z_k/znrm
call psb_spmm(done,a,tq,dzero,tt,desc_a,info) ! t_{k+1} = BA q_k
call sm%sv%apply_v(done,tt,dzero,tz,desc_a,'NoTrans',work,wv,info) ! z_{k+1} = B t_{k+1}
lambda = psb_gedot(tq,tz,desc_a,info) ! lambda = q_k^T z_{k+1} = q_k^T BA q_k
!write(0,*) 'BLD: lambda estimate ',i,lambda
end do
sm%rho_ba = lambda
end block
case default
write(0,*) ' Unknown algorithm for RHO(BA) estimate, defaulting to a value of 1.0 '
sm%rho_ba = done
end select
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_bld

70
amgprec/impl/smoother/amg_d_poly_smoother_clear_data.f90
Unescape Escape View File

@ -0,0 +1,70 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_clear_data(sm,info)
use psb_base_mod
use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_clear_data
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='amg_d_poly_smoother_clear_data'
call psb_erractionsave(err_act)
info = 0
sm%pdegree = 0
if (allocated(sm%poly_beta)) deallocate(sm%poly_beta)
sm%pa => null()
if ((info==0).and.allocated(sm%sv)) then
call sm%sv%clear_data(info)
end if
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_clear_data

90
amgprec/impl/smoother/amg_d_poly_smoother_clone.f90
Unescape Escape View File

@ -0,0 +1,90 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_clone(sm,smout,info)
use psb_base_mod
use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_clone
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
class(amg_d_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: err_act
info=psb_success_
call psb_erractionsave(err_act)
if (allocated(smout)) then
call smout%free(info)
if (info == psb_success_) deallocate(smout, stat=info)
end if
if (info == psb_success_) &
& allocate(amg_d_poly_smoother_type :: smout, stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
goto 9999
end if
select type(smo => smout)
type is (amg_d_poly_smoother_type)
smo%pdegree = sm%pdegree
smo%rho_ba = sm%rho_ba
smo%poly_beta = sm%poly_beta
smo%pa => sm%pa
if ((info==psb_success_).and.(allocated(sm%sv))) then
allocate(smout%sv,mold=sm%sv,stat=info)
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
end if
class default
info = psb_err_internal_error_
end select
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_clone

102
amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90
Unescape Escape View File

@ -0,0 +1,102 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! asd on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_clone_settings(sm,smout,info)
use psb_base_mod
use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_clone_settings
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
class(amg_d_base_smoother_type), intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_poly_smoother_clone_settings'
call psb_erractionsave(err_act)
info = psb_success_
select type(smout)
class is(amg_d_poly_smoother_type)
smout%pa => null()
smout%pdegree = sm%pdegree
smout%variant = sm%variant
smout%cf_a = sm%cf_a
smout%rho_ba = sm%rho_ba
smout%rho_estimate = sm%rho_estimate
smout%rho_estimate_iterations = sm%rho_estimate_iterations
smout%poly_beta = sm%poly_beta
if (allocated(smout%sv)) then
if (.not.same_type_as(sm%sv,smout%sv)) then
call smout%sv%free(info)
if (info == 0) deallocate(smout%sv,stat=info)
end if
end if
if (info /= 0) then
info = psb_err_internal_error_
else
if (allocated(smout%sv)) then
if (same_type_as(sm%sv,smout%sv)) then
call sm%sv%clone_settings(smout%sv,info)
else
info = psb_err_internal_error_
end if
else
allocate(smout%sv,mold=sm%sv,stat=info)
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
if (info /= 0) info = psb_err_internal_error_
end if
end if
class default
info = psb_err_internal_error_
end select
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_clone_settings

77
amgprec/impl/smoother/amg_d_poly_smoother_cnv.f90
Unescape Escape View File

@ -0,0 +1,77 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_cnv(sm,info,amold,vmold,imold)
use psb_base_mod
use amg_d_diag_solver
use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_cnv
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
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
! Local variables
integer(psb_ipk_) :: i, err_act, debug_unit, debug_level
character(len=20) :: name='d_poly_smoother_cnv', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (allocated(sm%sv)) &
& call sm%sv%cnv(info,amold=amold,vmold=vmold,imold=imold)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='solver cnv')
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_cnv

76
amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90
Unescape Escape View File

@ -0,0 +1,76 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_csetc(sm,what,val,info,idx)
use psb_base_mod
use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_csetc
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act, ival
character(len=20) :: name='d_poly_smoother_csetc'
info = psb_success_
call psb_erractionsave(err_act)
select case(psb_toupper(trim(what)))
case('POLY_VARIANT')
call sm%set(what,amg_stringval(val),info,idx=idx)
case('POLY_RHO_ESTIMATE')
call sm%set(what,amg_stringval(val),info,idx=idx)
case default
call sm%amg_d_base_smoother_type%set(what,val,info,idx=idx)
end select
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_csetc

92
amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90
Unescape Escape View File

@ -0,0 +1,92 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_cseti(sm,what,val,info,idx)
use psb_base_mod
use amg_d_poly_smoother, amg_protect_nam => amg_d_poly_smoother_cseti
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_poly_smoother_cseti'
info = psb_success_
call psb_erractionsave(err_act)
select case(psb_toupper(what))
case('POLY_DEGREE')
sm%pdegree = val
case('POLY_VARIANT')
select case(val)
case(amg_poly_lottes_,amg_poly_lottes_beta_,amg_poly_new_)
sm%variant = val
case default
write(0,*) 'Invalid choice for POLY_VARIANT, defaulting to amg_poly_lottes_',val
sm%variant = amg_poly_lottes_
end select
case('POLY_RHO_ESTIMATE')
select case(val)
case (amg_poly_rho_est_power_)
sm%rho_estimate = val
case default
write(0,*) 'Invalid choice for POLY_RHO_ESTIMATE, defaulting to amg_poly_rho_power'
sm%variant = amg_poly_rho_est_power_
end select
case('POLY_RHO_ESTIMATE_ITERATIONS')
if (val>0) then
sm%rho_estimate_iterations = val
else
write(0,*) 'Invalid choice for POLY_RHO_ESTIMATE_ITERATIONS, defaulting to 20'
sm%variant = 20
end if
case default
call sm%amg_d_base_smoother_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_cseti

74
amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90
Unescape Escape View File

@ -0,0 +1,74 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_csetr(sm,what,val,info,idx)
use psb_base_mod
use amg_d_poly_smoother, amg_protect_nam => amg_d_poly_smoother_csetr
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_poly_smoother_csetr'
info = psb_success_
call psb_erractionsave(err_act)
select case(psb_toupper(what))
case('POLY_RHO_BA')
if ((dzero<val).and.(val<=done)) then
sm%rho_ba = val
else
write(0,*) 'Invalid choice for POLY_RHO_BA, defaulting to compute estimate'
sm%rho_ba = -done
end if
case default
call sm%amg_d_base_smoother_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_csetr

108
amgprec/impl/smoother/amg_d_poly_smoother_descr.f90
Unescape Escape View File

@ -0,0 +1,108 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix)
use psb_base_mod
use amg_d_diag_solver
use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_descr
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(in) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='amg_d_poly_smoother_descr'
integer(psb_ipk_) :: iout_
logical :: coarse_
character(1024) :: prefix_
call psb_erractionsave(err_act)
info = psb_success_
if (present(coarse)) then
coarse_ = coarse
else
coarse_ = .false.
end if
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
endif
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
write(iout_,*) trim(prefix_), ' Polynomial smoother '
select case(sm%variant)
case(amg_poly_lottes_)
write(iout_,*) trim(prefix_), ' variant: ','POLY_LOTTES'
write(iout_,*) trim(prefix_), ' Degree: ',sm%pdegree
write(iout_,*) trim(prefix_), ' rho_ba: ',sm%rho_ba
case(amg_poly_lottes_beta_)
write(iout_,*) trim(prefix_), ' variant: ','POLY_LOTTES_BETA'
write(iout_,*) trim(prefix_), ' Degree: ',sm%pdegree
write(iout_,*) trim(prefix_), ' rho_ba: ',sm%rho_ba
if (allocated(sm%poly_beta)) write(iout_,*) trim(prefix_), ' Coefficients: ',sm%poly_beta(1:sm%pdegree)
case(amg_poly_new_)
write(iout_,*) trim(prefix_), ' variant: ','POLY_NEW'
write(iout_,*) trim(prefix_), ' Degree: ',sm%pdegree
write(iout_,*) trim(prefix_), ' rho_ba: ',sm%rho_ba
write(iout_,*) trim(prefix_), ' Coefficient: ',sm%cf_a
case default
write(iout_,*) trim(prefix_), ' variant: ','UNKNOWN???'
end select
if (allocated(sm%sv)) then
write(iout_,*) trim(prefix_), ' Local solver details:'
call sm%sv%descr(info,iout_,coarse=coarse,prefix=prefix)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_poly_smoother_descr

90
amgprec/impl/smoother/amg_d_poly_smoother_dmp.f90
Unescape Escape View File

@ -0,0 +1,90 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_d_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
use psb_base_mod
use amg_d_poly_smoother, amg_protect_nam => amg_d_poly_smoother_dmp
implicit none
class(amg_d_poly_smoother_type), intent(in) :: sm
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: level
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver, global_num
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: iam, np
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
integer(psb_lpk_), allocatable :: iv(:)
logical :: smoother_, global_num_
! len of prefix_
info = 0
if (present(prefix)) then
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
else
prefix_ = "dump_smth_d"
end if
ctxt = desc%get_context()
call psb_info(ctxt,iam,np)
if (present(smoother)) then
smoother_ = smoother
else
smoother_ = .false.
end if
if (present(global_num)) then
global_num_ = global_num
else
global_num_ = .false.
end if
lname = len_trim(prefix_)
fname = trim(prefix_)
write(fname(lname+1:lname+5),'(a,i3.3)') '_poly',iam
lname = lname + 8
! to be completed
! At base level do nothing for the smoother
if (allocated(sm%sv)) &
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
end subroutine amg_d_poly_smoother_dmp

2
amgprec/impl/smoother/amg_s_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -175,7 +175,7 @@ subroutine amg_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if (info /= psb_success_) exit
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
call psb_geaxpby(sone,x,szero,r,r,desc_data,info)
call psb_geaxpby(sone,x,szero,r,desc_data,info)
call psb_spmm(-sone,sm%pa,ty,sone,r,desc_data,info)
res = psb_genrm2(r,desc_data,info)
if( sm%printres ) then

281
amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90
Unescape Escape View File

@ -0,0 +1,281 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use amg_s_diag_solver
use psb_base_krylov_conv_mod, only : log_conv
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_apply_vect
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_s_poly_smoother_type), intent(inout) :: sm
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps! this is ignored here, the polynomial degree dictates the value
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
! Timers
logical, parameter :: do_timings=.true.
integer(psb_ipk_), save :: poly_1=-1, poly_2=-1, poly_3=-1
integer(psb_ipk_), save :: poly_mv=-1, poly_sv=-1, poly_vect=-1
!
integer(psb_ipk_) :: n_row,n_col
type(psb_s_vect_type) :: tx, ty, tz, r
real(psb_spk_), pointer :: aux(:)
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, i, err_act
character :: trans_, init_
real(psb_spk_) :: res, resdenum
character(len=20) :: name='d_poly_smoother_apply_v'
call psb_erractionsave(err_act)
info = psb_success_
ctxt = desc_data%get_context()
call psb_info(ctxt,me,np)
if (present(init)) then
init_ = psb_toupper(init)
else
init_='Z'
end if
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
if (.not.allocated(sm%sv)) then
info = 1121
call psb_errpush(info,name)
goto 9999
end if
if ((do_timings).and.(poly_1==-1)) &
& poly_1 = psb_get_timer_idx("POLY: Chebychev4")
if ((do_timings).and.(poly_2==-1)) &
& poly_2 = psb_get_timer_idx("POLY: OptChebychev4")
if ((do_timings).and.(poly_3==-1)) &
& poly_3 = psb_get_timer_idx("POLY: OptChebychev1")
if ((do_timings).and.(poly_mv==-1)) &
& poly_mv = psb_get_timer_idx("POLY: spMV")
if ((do_timings).and.(poly_vect==-1)) &
& poly_vect = psb_get_timer_idx("POLY: Vectors")
if ((do_timings).and.(poly_sv==-1)) &
& poly_sv = psb_get_timer_idx("POLY: solver")
n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols()
if (4*n_col <= size(work)) then
aux => work(:)
else
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,&
& i_err=(/4*n_col,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
endif
if (size(wv) < 4) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2), tz => wv(3), r => wv(4))
call psb_geaxpby(sone,x,szero,r,desc_data,info)
call tx%zero()
call ty%zero()
call tz%zero()
select case(sm%variant)
case(amg_poly_lottes_)
if (do_timings) call psb_tic(poly_1)
block
real(psb_spk_) :: cz, cr
! b == x
! x == tx
!
do i=1, sm%pdegree-1
! B r_{k-1}
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') ! ty = M^{-1} r
if (do_timings) call psb_toc(poly_sv)
cz = (2*i*sone-3)/(2*i*sone+sone)
cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz(cr,cz,sone,sone,ty,tz,tx,desc_data,info) ! zk = cz * zk-1 + cr * rk-1
if (do_timings) call psb_toc(poly_vect)
if (do_timings) call psb_tic(poly_mv)
call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_)
if (do_timings) call psb_toc(poly_mv)
end do
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') ! ty = M^{-1} r
if (do_timings) call psb_toc(poly_sv)
cz = (2*sm%pdegree*sone-3)/(2*sm%pdegree*sone+sone)
cr = (8*sm%pdegree*sone-4)/((2*sm%pdegree*sone+sone)*sm%rho_ba)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz(cr,cz,sone,sone,ty,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
end block
if (do_timings) call psb_toc(poly_1)
case(amg_poly_lottes_beta_)
if (do_timings) call psb_tic(poly_2)
block
real(psb_spk_) :: cz, cr
! b == x
! x == tx
!
if (allocated(sm%poly_beta)) then
if (size(sm%poly_beta) /= sm%pdegree) deallocate(sm%poly_beta)
end if
if (.not.allocated(sm%poly_beta)) then
call psb_realloc(sm%pdegree,sm%poly_beta,info)
sm%poly_beta(1:sm%pdegree) = amg_d_poly_beta_mat(1:sm%pdegree,sm%pdegree)
end if
do i=1, sm%pdegree-1
! B r_{k-1}
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z')
if (do_timings) call psb_toc(poly_sv)
cz = (2*i*sone-3)/(2*i*sone+sone)
cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz(cr,cz,sm%poly_beta(i),sone,ty,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
if (do_timings) call psb_tic(poly_mv)
call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_)
if (do_timings) call psb_toc(poly_mv)
end do
call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z')
cz = (2*sm%pdegree*sone-3)/(2*sm%pdegree*sone+sone)
cr = (8*sm%pdegree*sone-4)/((2*sm%pdegree*sone+sone)*sm%rho_ba)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz(cr,cz,sm%poly_beta(sm%pdegree),sone,ty,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
end block
if (do_timings) call psb_toc(poly_2)
case(amg_poly_new_)
if (do_timings) call psb_tic(poly_3)
block
real(psb_spk_) :: sigma, theta, delta, rho_old, rho
! b == x
! x == tx
!
theta = (sone+sm%cf_a)/2
delta = (sone-sm%cf_a)/2
sigma = theta/delta
rho_old = sone/sigma
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z')
if (do_timings) call psb_toc(poly_sv)
call psb_geaxpby((sone/sm%rho_ba),ty,szero,r,desc_data,info)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz((sone/theta),szero,sone,sone,r,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
! tz == d
do i=1, sm%pdegree-1
!
!
! r_{k-1} = r_k - (1/rho(BA)) B A d_k
if (do_timings) call psb_tic(poly_mv)
call psb_spmm(sone,sm%pa,tz,szero,ty,desc_data,info,work=aux,trans=trans_)
if (do_timings) call psb_toc(poly_mv)
if (do_timings) call psb_tic(poly_sv)
call sm%sv%apply(-(sone/sm%rho_ba),ty,sone,r,desc_data,trans_,aux,wv(5:),info,init='Z')
if (do_timings) call psb_toc(poly_sv)
!
! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1}
rho = sone/(2*sigma - rho_old)
if (do_timings) call psb_tic(poly_vect)
call psb_abgdxyz((2*rho/delta),(rho*rho_old),sone,sone,r,tz,tx,desc_data,info)
if (do_timings) call psb_toc(poly_vect)
rho_old = rho
end do
end block
if (do_timings) call psb_toc(poly_3)
case default
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='wrong polynomial variant')
goto 9999
end select
if (info == psb_success_) call psb_geaxpby(alpha,tx,beta,y,desc_data,info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='polynomial smoother')
goto 9999
end if
end associate
if (.not.(4*n_col <= size(work))) then
deallocate(aux)
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_s_poly_smoother_apply_vect

179
amgprec/impl/smoother/amg_s_poly_smoother_bld.f90
Unescape Escape View File

@ -0,0 +1,179 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
use psb_base_mod
use amg_s_diag_solver
use amg_s_l1_diag_solver
use amg_d_poly_coeff_mod
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_bld
Implicit None
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_s_poly_smoother_type), intent(inout) :: sm
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
! Local variables
type(psb_sspmat_type) :: tmpa
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
type(psb_ctxt_type) :: ctxt
real(psb_spk_), allocatable :: da(:), dsv(:)
integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level
character(len=20) :: name='d_poly_smoother_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
n_row = desc_a%get_local_rows()
n_col = desc_a%get_local_cols()
nrow_a = a%get_nrows()
nztota = a%get_nzeros()
select case(sm%variant)
case(amg_poly_lottes_)
! do nothing
case(amg_poly_lottes_beta_)
if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then
call psb_realloc(sm%pdegree,sm%poly_beta,info)
sm%poly_beta(1:sm%pdegree) = amg_d_poly_beta_mat(1:sm%pdegree,sm%pdegree)
else
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid sm%degree for poly_beta')
goto 9999
end if
case(amg_poly_new_)
if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then
!Ok
sm%cf_a = amg_d_poly_a_vect(sm%pdegree)
else
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid sm%degree for poly_a')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid sm%variant')
goto 9999
end select
sm%pa => a
if (.not.allocated(sm%sv)) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='unallocated sm%sv')
goto 9999
end if
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='sv%build')
goto 9999
end if
!!$ if (.false.) then
!!$ select type(ssv => sm%sv)
!!$ class is(amg_s_l1_diag_solver_type)
!!$ da = a%arwsum(info)
!!$ dsv = ssv%dv%get_vect()
!!$ sm%rho_ba = maxval(da(1:n_row)*dsv(1:n_row))
!!$ class default
!!$ write(0,*) 'PolySmoother BUILD: only L1-Jacobi/L1-DIAG for now ',ssv%get_fmt()
!!$ sm%rho_ba = sone
!!$ end select
!!$ else
if (sm%rho_ba <= szero) then
select case(sm%rho_estimate)
case(amg_poly_rho_est_power_)
block
type(psb_s_vect_type) :: tq, tt, tz,wv(2)
real(psb_spk_) :: znrm, lambda
real(psb_spk_),allocatable :: work(:)
integer(psb_ipk_) :: i, n_cols
n_cols = desc_a%get_local_cols()
allocate(work(4*n_cols))
call psb_geasb(tz,desc_a,info,mold=vmold,scratch=.true.)
call psb_geasb(tt,desc_a,info,mold=vmold,scratch=.true.)
call psb_geasb(wv(1),desc_a,info,mold=vmold,scratch=.true.)
call psb_geasb(wv(2),desc_a,info,mold=vmold,scratch=.true.)
call psb_geall(tq,desc_a,info)
call tq%set(sone)
call psb_geasb(tq,desc_a,info,mold=vmold)
call psb_spmm(sone,a,tq,szero,tt,desc_a,info) !
call sm%sv%apply_v(sone,tt,szero,tz,desc_a,'NoTrans',work,wv,info) ! z_{k+1} = BA q_k
do i=1,sm%rho_estimate_iterations
znrm = psb_genrm2(tz,desc_a,info) ! znrm = |z_k|_2
call psb_geaxpby((sone/znrm),tz,szero,tq,desc_a,info) ! q_k = z_k/znrm
call psb_spmm(sone,a,tq,szero,tt,desc_a,info) ! t_{k+1} = BA q_k
call sm%sv%apply_v(sone,tt,szero,tz,desc_a,'NoTrans',work,wv,info) ! z_{k+1} = B t_{k+1}
lambda = psb_gedot(tq,tz,desc_a,info) ! lambda = q_k^T z_{k+1} = q_k^T BA q_k
!write(0,*) 'BLD: lambda estimate ',i,lambda
end do
sm%rho_ba = lambda
end block
case default
write(0,*) ' Unknown algorithm for RHO(BA) estimate, defaulting to a value of 1.0 '
sm%rho_ba = sone
end select
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_s_poly_smoother_bld

70
amgprec/impl/smoother/amg_s_poly_smoother_clear_data.f90
Unescape Escape View File

@ -0,0 +1,70 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_poly_smoother_clear_data(sm,info)
use psb_base_mod
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_clear_data
Implicit None
! Arguments
class(amg_s_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='amg_s_poly_smoother_clear_data'
call psb_erractionsave(err_act)
info = 0
sm%pdegree = 0
if (allocated(sm%poly_beta)) deallocate(sm%poly_beta)
sm%pa => null()
if ((info==0).and.allocated(sm%sv)) then
call sm%sv%clear_data(info)
end if
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_s_poly_smoother_clear_data

90
amgprec/impl/smoother/amg_s_poly_smoother_clone.f90
Unescape Escape View File

@ -0,0 +1,90 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! 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 AMG4PSBLAS 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 AMG4PSBLAS 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 amg_s_poly_smoother_clone(sm,smout,info)
use psb_base_mod
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_clone
Implicit None
! Arguments
class(amg_s_poly_smoother_type), intent(inout) :: sm
class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: err_act
info=psb_success_
call psb_erractionsave(err_act)
if (allocated(smout)) then
call smout%free(info)
if (info == psb_success_) deallocate(smout, stat=info)
end if
if (info == psb_success_) &
& allocate(amg_s_poly_smoother_type :: smout, stat=info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
goto 9999
end if
select type(smo => smout)
type is (amg_s_poly_smoother_type)
smo%pdegree = sm%pdegree
smo%rho_ba = sm%rho_ba
smo%poly_beta = sm%poly_beta
smo%pa => sm%pa
if ((info==psb_success_).and.(allocated(sm%sv))) then
allocate(smout%sv,mold=sm%sv,stat=info)
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
end if
class default
info = psb_err_internal_error_
end select
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_s_poly_smoother_clone

Some files were not shown because too many files have changed in this diff Show More

Write Preview
Loading…
Cancel
Save