diff --git a/amgprec/Makefile b/amgprec/Makefile index 81e6ce8c..c6ccb4b7 100644 --- a/amgprec/Makefile +++ b/amgprec/Makefile @@ -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 diff --git a/amgprec/amg_base_prec_type.F90 b/amgprec/amg_base_prec_type.F90 index bd3ca19c..60aacaec 100644 --- a/amgprec/amg_base_prec_type.F90 +++ b/amgprec/amg_base_prec_type.F90 @@ -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) diff --git a/amgprec/amg_c_ilu_solver.f90 b/amgprec/amg_c_ilu_solver.f90 index 7a269d85..d9b4a1d2 100644 --- a/amgprec/amg_c_ilu_solver.f90 +++ b/amgprec/amg_c_ilu_solver.f90 @@ -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) diff --git a/amgprec/amg_c_onelev_mod.f90 b/amgprec/amg_c_onelev_mod.f90 index 2cef1397..d926e2bf 100644 --- a/amgprec/amg_c_onelev_mod.f90 +++ b/amgprec/amg_c_onelev_mod.f90 @@ -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_, & diff --git a/amgprec/amg_c_prec_type.f90 b/amgprec/amg_c_prec_type.f90 index 9fd5afc5..2ce58807 100644 --- a/amgprec/amg_c_prec_type.f90 +++ b/amgprec/amg_c_prec_type.f90 @@ -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 diff --git a/amgprec/amg_d_ilu_solver.f90 b/amgprec/amg_d_ilu_solver.f90 index 00733655..c7813e6e 100644 --- a/amgprec/amg_d_ilu_solver.f90 +++ b/amgprec/amg_d_ilu_solver.f90 @@ -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) diff --git a/amgprec/amg_d_onelev_mod.f90 b/amgprec/amg_d_onelev_mod.f90 index 60ed9448..51c482cb 100644 --- a/amgprec/amg_d_onelev_mod.f90 +++ b/amgprec/amg_d_onelev_mod.f90 @@ -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_, & diff --git a/amgprec/amg_d_poly_coeff_mod.f90 b/amgprec/amg_d_poly_coeff_mod.f90 new file mode 100644 index 00000000..69c56aba --- /dev/null +++ b/amgprec/amg_d_poly_coeff_mod.f90 @@ -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 diff --git a/amgprec/amg_d_poly_smoother.f90 b/amgprec/amg_d_poly_smoother.f90 new file mode 100644 index 00000000..a87fbb1b --- /dev/null +++ b/amgprec/amg_d_poly_smoother.f90 @@ -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 diff --git a/amgprec/amg_d_prec_type.f90 b/amgprec/amg_d_prec_type.f90 index 9fbc2b5d..e2c48cc2 100644 --- a/amgprec/amg_d_prec_type.f90 +++ b/amgprec/amg_d_prec_type.f90 @@ -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 diff --git a/amgprec/amg_s_ilu_solver.f90 b/amgprec/amg_s_ilu_solver.f90 index dd642746..8bca532b 100644 --- a/amgprec/amg_s_ilu_solver.f90 +++ b/amgprec/amg_s_ilu_solver.f90 @@ -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) diff --git a/amgprec/amg_s_onelev_mod.f90 b/amgprec/amg_s_onelev_mod.f90 index c826001d..f11b64ca 100644 --- a/amgprec/amg_s_onelev_mod.f90 +++ b/amgprec/amg_s_onelev_mod.f90 @@ -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_, & diff --git a/amgprec/amg_s_poly_smoother.f90 b/amgprec/amg_s_poly_smoother.f90 new file mode 100644 index 00000000..79cbcb00 --- /dev/null +++ b/amgprec/amg_s_poly_smoother.f90 @@ -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 diff --git a/amgprec/amg_s_prec_type.f90 b/amgprec/amg_s_prec_type.f90 index 88a22078..e64703bc 100644 --- a/amgprec/amg_s_prec_type.f90 +++ b/amgprec/amg_s_prec_type.f90 @@ -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 diff --git a/amgprec/amg_z_ilu_solver.f90 b/amgprec/amg_z_ilu_solver.f90 index 48b5ff1f..f2c6f29b 100644 --- a/amgprec/amg_z_ilu_solver.f90 +++ b/amgprec/amg_z_ilu_solver.f90 @@ -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) diff --git a/amgprec/amg_z_onelev_mod.f90 b/amgprec/amg_z_onelev_mod.f90 index 78259f4d..fffe88c0 100644 --- a/amgprec/amg_z_onelev_mod.f90 +++ b/amgprec/amg_z_onelev_mod.f90 @@ -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_, & diff --git a/amgprec/amg_z_prec_type.f90 b/amgprec/amg_z_prec_type.f90 index 7b9ad346..adeecf23 100644 --- a/amgprec/amg_z_prec_type.f90 +++ b/amgprec/amg_z_prec_type.f90 @@ -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 diff --git a/amgprec/impl/Makefile b/amgprec/impl/Makefile index 826c7dd1..08065b8d 100644 --- a/amgprec/impl/Makefile +++ b/amgprec/impl/Makefile @@ -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 diff --git a/amgprec/impl/aggregator/MatchBoxPC.cpp b/amgprec/impl/aggregator/MatchBoxPC.cpp index baaa39d0..8295c0af 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.cpp +++ b/amgprec/impl/aggregator/MatchBoxPC.cpp @@ -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 } diff --git a/amgprec/impl/aggregator/MatchBoxPC.h b/amgprec/impl/aggregator/MatchBoxPC.h index 67486f2d..0afc9b3c 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.h +++ b/amgprec/impl/aggregator/MatchBoxPC.h @@ -59,7 +59,11 @@ #include #include #include +#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 &U, - vector &privateU, - vector &QLocalVtx, - vector &QGhostVtx, - vector &QMsgType, - vector &QOwner, - vector &privateQLocalVtx, - vector &privateQGhostVtx, - vector &privateQMsgType, - vector &privateQOwner); - - bool isAlreadyMatched(MilanLongInt node, - MilanLongInt StartIndex, - MilanLongInt EndIndex, - vector &GMate, - MilanLongInt *Mate, - map &Ghost2LocalMap); - - MilanLongInt computeCandidateMate(MilanLongInt adj1, - MilanLongInt adj2, - MilanReal *edgeLocWeight, - MilanLongInt k, - MilanLongInt *verLocInd, - MilanLongInt StartIndex, - MilanLongInt EndIndex, - vector &GMate, - MilanLongInt *Mate, - map &Ghost2LocalMap); - - void initialize(MilanLongInt NLVer, MilanLongInt NLEdge, - MilanLongInt StartIndex, MilanLongInt EndIndex, - MilanLongInt *numGhostEdgesPtr, - MilanLongInt *numGhostVerticesPtr, - MilanLongInt *S, - MilanLongInt *verLocInd, - MilanLongInt *verLocPtr, - map &Ghost2LocalMap, - vector &Counter, - vector &verGhostPtr, - vector &verGhostInd, - vector &tempCounter, - vector &GMate, - vector &Message, - vector &QLocalVtx, - vector &QGhostVtx, - vector &QMsgType, - vector &QOwner, - MilanLongInt *&candidateMate, - vector &U, - vector &privateU, - vector &privateQLocalVtx, - vector &privateQGhostVtx, - vector &privateQMsgType, - vector &privateQOwner); - - void clean(MilanLongInt NLVer, - MilanInt myRank, - MilanLongInt MessageIndex, - vector &SRequest, - vector &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 &GMate, - map &Ghost2LocalMap, - MilanReal *edgeLocWeight, - MilanLongInt *myCardPtr, - MilanLongInt *msgIndPtr, - MilanLongInt *NumMessagesBundledPtr, - MilanLongInt *SPtr, - MilanLongInt *verDistance, - MilanLongInt *PCounter, - vector &Counter, - MilanInt myRank, - MilanInt numProcs, - vector &U, - vector &privateU, - vector &QLocalVtx, - vector &QGhostVtx, - vector &QMsgType, - vector &QOwner, - vector &privateQLocalVtx, - vector &privateQGhostVtx, - vector &privateQMsgType, - vector &privateQOwner); - - void PROCESS_CROSS_EDGE(MilanLongInt *edge, - MilanLongInt *SPtr); - - void processMatchedVertices( - MilanLongInt NLVer, - vector &UChunkBeingProcessed, - vector &U, - vector &privateU, - MilanLongInt StartIndex, - MilanLongInt EndIndex, - MilanLongInt *myCardPtr, - MilanLongInt *msgIndPtr, - MilanLongInt *NumMessagesBundledPtr, - MilanLongInt *SPtr, - MilanLongInt *verLocPtr, - MilanLongInt *verLocInd, - MilanLongInt *verDistance, - MilanLongInt *PCounter, - vector &Counter, - MilanInt myRank, - MilanInt numProcs, - MilanLongInt *candidateMate, - vector &GMate, - MilanLongInt *Mate, - map &Ghost2LocalMap, - MilanReal *edgeLocWeight, - vector &QLocalVtx, - vector &QGhostVtx, - vector &QMsgType, - vector &QOwner, - vector &privateQLocalVtx, - vector &privateQGhostVtx, - vector &privateQMsgType, - vector &privateQOwner); - - void processMatchedVerticesAndSendMessages( - MilanLongInt NLVer, - vector &UChunkBeingProcessed, - vector &U, - vector &privateU, - MilanLongInt StartIndex, - MilanLongInt EndIndex, - MilanLongInt *myCardPtr, - MilanLongInt *msgIndPtr, - MilanLongInt *NumMessagesBundledPtr, - MilanLongInt *SPtr, - MilanLongInt *verLocPtr, - MilanLongInt *verLocInd, - MilanLongInt *verDistance, - MilanLongInt *PCounter, - vector &Counter, - MilanInt myRank, - MilanInt numProcs, - MilanLongInt *candidateMate, - vector &GMate, - MilanLongInt *Mate, - map &Ghost2LocalMap, - MilanReal *edgeLocWeight, - vector &QLocalVtx, - vector &QGhostVtx, - vector &QMsgType, - vector &QOwner, - vector &privateQLocalVtx, - vector &privateQGhostVtx, - vector &privateQMsgType, - vector &privateQOwner, - MPI_Comm comm, - MilanLongInt *msgActual, - vector &Message); - - void sendBundledMessages(MilanLongInt *numGhostEdgesPtr, - MilanInt *BufferSizePtr, - MilanLongInt *Buffer, - vector &PCumulative, - vector &PMessageBundle, - vector &PSizeInfoMessages, - MilanLongInt *PCounter, - MilanLongInt NumMessagesBundled, - MilanLongInt *msgActualPtr, - MilanLongInt *MessageIndexPtr, - MilanInt numProcs, - MilanInt myRank, - MPI_Comm comm, - vector &QLocalVtx, - vector &QGhostVtx, - vector &QMsgType, - vector &QOwner, - vector &SRequest, - vector &SStatus); - - void processMessages( - MilanLongInt NLVer, - MilanLongInt *Mate, - MilanLongInt *candidateMate, - map &Ghost2LocalMap, - vector &GMate, - vector &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 &Message, - MilanLongInt numGhostEdges, - MilanLongInt u, - MilanLongInt v, - MilanLongInt *SPtr, - vector &U); - - void extractUChunk( - vector &UChunkBeingProcessed, - vector &U, - vector &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 &U, + vector &privateU, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &privateQOwner); + + bool isAlreadyMatched(MilanLongInt node, + MilanLongInt StartIndex, + MilanLongInt EndIndex, + vector &GMate, + MilanLongInt *Mate, + map &Ghost2LocalMap); + + MilanLongInt computeCandidateMateD(MilanLongInt adj1, + MilanLongInt adj2, + MilanReal *edgeLocWeight, + MilanLongInt k, + MilanLongInt *verLocInd, + MilanLongInt StartIndex, + MilanLongInt EndIndex, + vector &GMate, + MilanLongInt *Mate, + map &Ghost2LocalMap); + + void initialize(MilanLongInt NLVer, MilanLongInt NLEdge, + MilanLongInt StartIndex, MilanLongInt EndIndex, + MilanLongInt *numGhostEdgesPtr, + MilanLongInt *numGhostVerticesPtr, + MilanLongInt *S, + MilanLongInt *verLocInd, + MilanLongInt *verLocPtr, + map &Ghost2LocalMap, + vector &Counter, + vector &verGhostPtr, + vector &verGhostInd, + vector &tempCounter, + vector &GMate, + vector &Message, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + MilanLongInt *&candidateMate, + vector &U, + vector &privateU, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &privateQOwner); + + void clean(MilanLongInt NLVer, + MilanInt myRank, + MilanLongInt MessageIndex, + vector &SRequest, + vector &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 &GMate, + map &Ghost2LocalMap, + MilanReal *edgeLocWeight, + MilanLongInt *myCardPtr, + MilanLongInt *msgIndPtr, + MilanLongInt *NumMessagesBundledPtr, + MilanLongInt *SPtr, + MilanLongInt *verDistance, + MilanLongInt *PCounter, + vector &Counter, + MilanInt myRank, + MilanInt numProcs, + vector &U, + vector &privateU, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &privateQOwner); + + void PROCESS_CROSS_EDGE(MilanLongInt *edge, + MilanLongInt *SPtr); + + void processMatchedVerticesD( + MilanLongInt NLVer, + vector &UChunkBeingProcessed, + vector &U, + vector &privateU, + MilanLongInt StartIndex, + MilanLongInt EndIndex, + MilanLongInt *myCardPtr, + MilanLongInt *msgIndPtr, + MilanLongInt *NumMessagesBundledPtr, + MilanLongInt *SPtr, + MilanLongInt *verLocPtr, + MilanLongInt *verLocInd, + MilanLongInt *verDistance, + MilanLongInt *PCounter, + vector &Counter, + MilanInt myRank, + MilanInt numProcs, + MilanLongInt *candidateMate, + vector &GMate, + MilanLongInt *Mate, + map &Ghost2LocalMap, + MilanReal *edgeLocWeight, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &privateQOwner); + + void processMatchedVerticesAndSendMessagesD( + MilanLongInt NLVer, + vector &UChunkBeingProcessed, + vector &U, + vector &privateU, + MilanLongInt StartIndex, + MilanLongInt EndIndex, + MilanLongInt *myCardPtr, + MilanLongInt *msgIndPtr, + MilanLongInt *NumMessagesBundledPtr, + MilanLongInt *SPtr, + MilanLongInt *verLocPtr, + MilanLongInt *verLocInd, + MilanLongInt *verDistance, + MilanLongInt *PCounter, + vector &Counter, + MilanInt myRank, + MilanInt numProcs, + MilanLongInt *candidateMate, + vector &GMate, + MilanLongInt *Mate, + map &Ghost2LocalMap, + MilanReal *edgeLocWeight, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &privateQOwner, + MPI_Comm comm, + MilanLongInt *msgActual, + vector &Message); + + void sendBundledMessages(MilanLongInt *numGhostEdgesPtr, + MilanInt *BufferSizePtr, + MilanLongInt *Buffer, + vector &PCumulative, + vector &PMessageBundle, + vector &PSizeInfoMessages, + MilanLongInt *PCounter, + MilanLongInt NumMessagesBundled, + MilanLongInt *msgActualPtr, + MilanLongInt *MessageIndexPtr, + MilanInt numProcs, + MilanInt myRank, + MPI_Comm comm, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &SRequest, + vector &SStatus); + + void processMessagesD( + MilanLongInt NLVer, + MilanLongInt *Mate, + MilanLongInt *candidateMate, + map &Ghost2LocalMap, + vector &GMate, + vector &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 &Message, + MilanLongInt numGhostEdges, + MilanLongInt u, + MilanLongInt v, + MilanLongInt *SPtr, + vector &U); + + void extractUChunk( + vector &UChunkBeingProcessed, + vector &U, + vector &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 &GMate, + MilanLongInt *Mate, + map &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 &GMate, + map &Ghost2LocalMap, + MilanFloat *edgeLocWeight, + MilanLongInt *myCardPtr, + MilanLongInt *msgIndPtr, + MilanLongInt *NumMessagesBundledPtr, + MilanLongInt *SPtr, + MilanLongInt *verDistance, + MilanLongInt *PCounter, + vector &Counter, + MilanInt myRank, + MilanInt numProcs, + vector &U, + vector &privateU, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &privateQOwner); + void processMatchedVerticesS( + MilanLongInt NLVer, + vector &UChunkBeingProcessed, + vector &U, + vector &privateU, + MilanLongInt StartIndex, + MilanLongInt EndIndex, + MilanLongInt *myCardPtr, + MilanLongInt *msgIndPtr, + MilanLongInt *NumMessagesBundledPtr, + MilanLongInt *SPtr, + MilanLongInt *verLocPtr, + MilanLongInt *verLocInd, + MilanLongInt *verDistance, + MilanLongInt *PCounter, + vector &Counter, + MilanInt myRank, + MilanInt numProcs, + MilanLongInt *candidateMate, + vector &GMate, + MilanLongInt *Mate, + map &Ghost2LocalMap, + MilanFloat *edgeLocWeight, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &privateQOwner); + + void processMatchedVerticesAndSendMessagesS( + MilanLongInt NLVer, + vector &UChunkBeingProcessed, + vector &U, + vector &privateU, + MilanLongInt StartIndex, + MilanLongInt EndIndex, + MilanLongInt *myCardPtr, + MilanLongInt *msgIndPtr, + MilanLongInt *NumMessagesBundledPtr, + MilanLongInt *SPtr, + MilanLongInt *verLocPtr, + MilanLongInt *verLocInd, + MilanLongInt *verDistance, + MilanLongInt *PCounter, + vector &Counter, + MilanInt myRank, + MilanInt numProcs, + MilanLongInt *candidateMate, + vector &GMate, + MilanLongInt *Mate, + map &Ghost2LocalMap, + MilanFloat *edgeLocWeight, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &privateQOwner, + MPI_Comm comm, + MilanLongInt *msgActual, + vector &Message); + + void processMessagesS( + MilanLongInt NLVer, + MilanLongInt *Mate, + MilanLongInt *candidateMate, + map &Ghost2LocalMap, + vector &GMate, + vector &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 &Message, + MilanLongInt numGhostEdges, + MilanLongInt u, + MilanLongInt v, + MilanLongInt *SPtr, + vector &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, diff --git a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.cpp b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.cpp index f03f726f..6ae18ebb 100644 --- a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.cpp +++ b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.cpp @@ -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("< 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 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 QLocalVtx, QGhostVtx, QMsgType; + // Changed by Fabio to be an integer, addresses needs to be integers! + vector 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 Ghost2LocalMap; + // Store the edge count for each ghost vertex + vector 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 verGhostPtr, verGhostInd, tempCounter; + // Mate array for ghost vertices: + vector GMate; // Proportional to the number of ghost vertices + MilanLongInt S; + MilanLongInt privateMyCard = 0; + vector PCumulative, PMessageBundle, PSizeInfoMessages; + vector SRequest; // Requests that are used for each send message + vector SStatus; // Status of sent messages, used in MPI_Wait + MilanLongInt MessageIndex = 0; // Pointer for current message + MilanInt BufferSize; + MilanLongInt *Buffer; + + vector privateQLocalVtx, privateQGhostVtx, privateQMsgType; + vector privateQOwner; + vector 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 " < 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 " < 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 &GMate, + MilanLongInt *Mate, + map &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 diff --git a/amgprec/impl/aggregator/extractUChunk.cpp b/amgprec/impl/aggregator/extractUChunk.cpp index 923a0b51..9f5bdfe2 100644 --- a/amgprec/impl/aggregator/extractUChunk.cpp +++ b/amgprec/impl/aggregator/extractUChunk.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" - void extractUChunk( vector &UChunkBeingProcessed, vector &U, @@ -28,4 +27,4 @@ void extractUChunk( } } // End of critical U // End of critical U -} \ No newline at end of file +} diff --git a/amgprec/impl/aggregator/findOwnerOfGhost.cpp b/amgprec/impl/aggregator/findOwnerOfGhost.cpp index b9d60614..779a5e7f 100644 --- a/amgprec/impl/aggregator/findOwnerOfGhost.cpp +++ b/amgprec/impl/aggregator/findOwnerOfGhost.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" - /// Find the owner of a ghost node: MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance, MilanInt myRank, MilanInt numProcs) diff --git a/amgprec/impl/aggregator/initialize.cpp b/amgprec/impl/aggregator/initialize.cpp index 17a4169e..baac9e8c 100644 --- a/amgprec/impl/aggregator/initialize.cpp +++ b/amgprec/impl/aggregator/initialize.cpp @@ -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); diff --git a/amgprec/impl/aggregator/isAlreadyMatched.cpp b/amgprec/impl/aggregator/isAlreadyMatched.cpp index a7d65c15..62cdca4b 100644 --- a/amgprec/impl/aggregator/isAlreadyMatched.cpp +++ b/amgprec/impl/aggregator/isAlreadyMatched.cpp @@ -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 -} \ No newline at end of file +} diff --git a/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp b/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp index cf340da2..35ce2bbd 100644 --- a/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp +++ b/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp @@ -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) } } diff --git a/amgprec/impl/aggregator/processCrossEdge.cpp b/amgprec/impl/aggregator/processCrossEdge.cpp index e844f127..d9d557a6 100644 --- a/amgprec/impl/aggregator/processCrossEdge.cpp +++ b/amgprec/impl/aggregator/processCrossEdge.cpp @@ -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 -} \ No newline at end of file +} diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index c53af9bb..b908d05f 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -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 &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 &GMate, + map &Ghost2LocalMap, + MilanFloat *edgeLocWeight, + MilanLongInt *myCard, + MilanLongInt *msgInd, + MilanLongInt *NumMessagesBundled, + MilanLongInt *S, + MilanLongInt *verDistance, + MilanLongInt *PCounter, + vector &Counter, + MilanInt myRank, + MilanInt numProcs, + vector &U, + vector &privateU, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &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 diff --git a/amgprec/impl/aggregator/processMatchedVertices.cpp b/amgprec/impl/aggregator/processMatchedVertices.cpp index eadc0531..acff6d92 100644 --- a/amgprec/impl/aggregator/processMatchedVertices.cpp +++ b/amgprec/impl/aggregator/processMatchedVertices.cpp @@ -1,7 +1,5 @@ #include "MatchBoxPC.h" - -#if !defined(SERIAL_MPI) -void processMatchedVertices( +void processMatchedVerticesD( MilanLongInt NLVer, vector &UChunkBeingProcessed, vector &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 &UChunkBeingProcessed, + vector &U, + vector &privateU, + MilanLongInt StartIndex, + MilanLongInt EndIndex, + MilanLongInt *myCard, + MilanLongInt *msgInd, + MilanLongInt *NumMessagesBundled, + MilanLongInt *SPtr, + MilanLongInt *verLocPtr, + MilanLongInt *verLocInd, + MilanLongInt *verDistance, + MilanLongInt *PCounter, + vector &Counter, + MilanInt myRank, + MilanInt numProcs, + MilanLongInt *candidateMate, + vector &GMate, + MilanLongInt *Mate, + map &Ghost2LocalMap, + MilanFloat *edgeLocWeight, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &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 } diff --git a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp index 922b5860..c0e51044 100644 --- a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp +++ b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp @@ -1,7 +1,6 @@ #include "MatchBoxPC.h" //#define DEBUG_HANG_ -#if !defined(SERIAL_MPI) -void processMatchedVerticesAndSendMessages( +void processMatchedVerticesAndSendMessagesD( MilanLongInt NLVer, vector &UChunkBeingProcessed, vector &U, @@ -27,6 +26,302 @@ void processMatchedVerticesAndSendMessages( vector &QLocalVtx, vector &QGhostVtx, vector &QMsgType, + vector &QOwner, + vector &privateQLocalVtx, + vector &privateQGhostVtx, + vector &privateQMsgType, + vector &privateQOwner, + MPI_Comm comm, + MilanLongInt *msgActual, + vector &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(), 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(), 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(), 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: "<(), ghostOwner, ComputeTag, comm); + //cout << myRank<<" Sending to "<(), ghostOwner, ComputeTag, comm); + } +#ifdef DEBUG_HANG_ + cout << myRank<<" Done sending messages"< &UChunkBeingProcessed, + vector &U, + vector &privateU, + MilanLongInt StartIndex, + MilanLongInt EndIndex, + MilanLongInt *myCard, + MilanLongInt *msgInd, + MilanLongInt *NumMessagesBundled, + MilanLongInt *SPtr, + MilanLongInt *verLocPtr, + MilanLongInt *verLocInd, + MilanLongInt *verDistance, + MilanLongInt *PCounter, + vector &Counter, + MilanInt myRank, + MilanInt numProcs, + MilanLongInt *candidateMate, + vector &GMate, + MilanLongInt *Mate, + map &Ghost2LocalMap, + MilanFloat *edgeLocWeight, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, vector &QOwner, vector &privateQLocalVtx, vector &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(), 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(), 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(), 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: "<(), ghostOwner, ComputeTag, comm); //cout << myRank<<" Sending to "<(), ghostOwner, ComputeTag, comm); diff --git a/amgprec/impl/aggregator/processMessages.cpp b/amgprec/impl/aggregator/processMessages.cpp index 2e3af9db..aeb03808 100644 --- a/amgprec/impl/aggregator/processMessages.cpp +++ b/amgprec/impl/aggregator/processMessages.cpp @@ -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, 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, 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 &Ghost2LocalMap, + vector &GMate, + vector &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 &Message, + MilanLongInt numGhostEdges, + MilanLongInt u, + MilanLongInt v, + MilanLongInt *S, + vector &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 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(), 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, 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 diff --git a/amgprec/impl/aggregator/queueTransfer.cpp b/amgprec/impl/aggregator/queueTransfer.cpp index b8b6a4bb..702db2cd 100644 --- a/amgprec/impl/aggregator/queueTransfer.cpp +++ b/amgprec/impl/aggregator/queueTransfer.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP void queuesTransfer(vector &U, vector &privateU, vector &QLocalVtx, diff --git a/amgprec/impl/aggregator/sendBundledMessages.cpp b/amgprec/impl/aggregator/sendBundledMessages.cpp index 07ea5834..c2837a4c 100644 --- a/amgprec/impl/aggregator/sendBundledMessages.cpp +++ b/amgprec/impl/aggregator/sendBundledMessages.cpp @@ -1,24 +1,23 @@ #include "MatchBoxPC.h" -#if !defined(SERIAL_MPI) void sendBundledMessages(MilanLongInt *numGhostEdges, - MilanInt *BufferSize, - MilanLongInt *Buffer, - vector &PCumulative, - vector &PMessageBundle, - vector &PSizeInfoMessages, - MilanLongInt *PCounter, - MilanLongInt NumMessagesBundled, - MilanLongInt *msgActual, - MilanLongInt *msgInd, - MilanInt numProcs, - MilanInt myRank, - MPI_Comm comm, - vector &QLocalVtx, - vector &QGhostVtx, - vector &QMsgType, - vector &QOwner, - vector &SRequest, - vector &SStatus) + MilanInt *BufferSize, + MilanLongInt *Buffer, + vector &PCumulative, + vector &PMessageBundle, + vector &PSizeInfoMessages, + MilanLongInt *PCounter, + MilanLongInt NumMessagesBundled, + MilanLongInt *msgActual, + MilanLongInt *msgInd, + MilanInt numProcs, + MilanInt myRank, + MPI_Comm comm, + vector &QLocalVtx, + vector &QGhostVtx, + vector &QMsgType, + vector &QOwner, + vector &SRequest, + vector &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 \ diff --git a/amgprec/impl/amg_c_hierarchy_bld.f90 b/amgprec/impl/amg_c_hierarchy_bld.F90 similarity index 90% rename from amgprec/impl/amg_c_hierarchy_bld.f90 rename to amgprec/impl/amg_c_hierarchy_bld.F90 index ba755550..e81e2868 100644 --- a/amgprec/impl/amg_c_hierarchy_bld.f90 +++ b/amgprec/impl/amg_c_hierarchy_bld.F90 @@ -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 diff --git a/amgprec/impl/amg_c_smoothers_bld.f90 b/amgprec/impl/amg_c_smoothers_bld.f90 index 8ad4d6eb..d684e389 100644 --- a/amgprec/impl/amg_c_smoothers_bld.f90 +++ b/amgprec/impl/amg_c_smoothers_bld.f90 @@ -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) diff --git a/amgprec/impl/amg_ccprecset.F90 b/amgprec/impl/amg_ccprecset.F90 index 9f4fb45f..c48dfd85 100644 --- a/amgprec/impl/amg_ccprecset.F90 +++ b/amgprec/impl/amg_ccprecset.F90 @@ -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_) diff --git a/amgprec/impl/amg_cfile_prec_descr.f90 b/amgprec/impl/amg_cfile_prec_descr.f90 index 396a9467..bdaa7c41 100644 --- a/amgprec/impl/amg_cfile_prec_descr.f90 +++ b/amgprec/impl/amg_cfile_prec_descr.f90 @@ -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 diff --git a/amgprec/impl/amg_cfile_prec_memory_use.f90 b/amgprec/impl/amg_cfile_prec_memory_use.f90 new file mode 100644 index 00000000..c578358c --- /dev/null +++ b/amgprec/impl/amg_cfile_prec_memory_use.f90 @@ -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 diff --git a/amgprec/impl/amg_cprecinit.F90 b/amgprec/impl/amg_cprecinit.F90 index 2335281b..5c08b1d1 100644 --- a/amgprec/impl/amg_cprecinit.F90 +++ b/amgprec/impl/amg_cprecinit.F90 @@ -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 diff --git a/amgprec/impl/amg_d_hierarchy_bld.f90 b/amgprec/impl/amg_d_hierarchy_bld.F90 similarity index 90% rename from amgprec/impl/amg_d_hierarchy_bld.f90 rename to amgprec/impl/amg_d_hierarchy_bld.F90 index c2452329..649362c8 100644 --- a/amgprec/impl/amg_d_hierarchy_bld.f90 +++ b/amgprec/impl/amg_d_hierarchy_bld.F90 @@ -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 diff --git a/amgprec/impl/amg_d_smoothers_bld.f90 b/amgprec/impl/amg_d_smoothers_bld.f90 index 76347dc4..c2bf3b99 100644 --- a/amgprec/impl/amg_d_smoothers_bld.f90 +++ b/amgprec/impl/amg_d_smoothers_bld.f90 @@ -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) diff --git a/amgprec/impl/amg_dcprecset.F90 b/amgprec/impl/amg_dcprecset.F90 index f70ff55c..c7ff4069 100644 --- a/amgprec/impl/amg_dcprecset.F90 +++ b/amgprec/impl/amg_dcprecset.F90 @@ -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_) diff --git a/amgprec/impl/amg_dfile_prec_descr.f90 b/amgprec/impl/amg_dfile_prec_descr.f90 index 3213df29..4cdde58f 100644 --- a/amgprec/impl/amg_dfile_prec_descr.f90 +++ b/amgprec/impl/amg_dfile_prec_descr.f90 @@ -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 diff --git a/amgprec/impl/amg_dfile_prec_memory_use.f90 b/amgprec/impl/amg_dfile_prec_memory_use.f90 new file mode 100644 index 00000000..d10cd5f3 --- /dev/null +++ b/amgprec/impl/amg_dfile_prec_memory_use.f90 @@ -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 diff --git a/amgprec/impl/amg_dprecinit.F90 b/amgprec/impl/amg_dprecinit.F90 index eaa861e9..176ceb0d 100644 --- a/amgprec/impl/amg_dprecinit.F90 +++ b/amgprec/impl/amg_dprecinit.F90 @@ -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 diff --git a/amgprec/impl/amg_s_hierarchy_bld.f90 b/amgprec/impl/amg_s_hierarchy_bld.F90 similarity index 90% rename from amgprec/impl/amg_s_hierarchy_bld.f90 rename to amgprec/impl/amg_s_hierarchy_bld.F90 index 3a69a9b6..b7b1d4a7 100644 --- a/amgprec/impl/amg_s_hierarchy_bld.f90 +++ b/amgprec/impl/amg_s_hierarchy_bld.F90 @@ -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 diff --git a/amgprec/impl/amg_s_smoothers_bld.f90 b/amgprec/impl/amg_s_smoothers_bld.f90 index 8149d3bb..00385c8a 100644 --- a/amgprec/impl/amg_s_smoothers_bld.f90 +++ b/amgprec/impl/amg_s_smoothers_bld.f90 @@ -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) diff --git a/amgprec/impl/amg_scprecset.F90 b/amgprec/impl/amg_scprecset.F90 index 36601f05..151b29cc 100644 --- a/amgprec/impl/amg_scprecset.F90 +++ b/amgprec/impl/amg_scprecset.F90 @@ -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_) diff --git a/amgprec/impl/amg_sfile_prec_descr.f90 b/amgprec/impl/amg_sfile_prec_descr.f90 index 5996e2a1..07bde2a4 100644 --- a/amgprec/impl/amg_sfile_prec_descr.f90 +++ b/amgprec/impl/amg_sfile_prec_descr.f90 @@ -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 diff --git a/amgprec/impl/amg_sfile_prec_memory_use.f90 b/amgprec/impl/amg_sfile_prec_memory_use.f90 new file mode 100644 index 00000000..bde5412a --- /dev/null +++ b/amgprec/impl/amg_sfile_prec_memory_use.f90 @@ -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 diff --git a/amgprec/impl/amg_sprecinit.F90 b/amgprec/impl/amg_sprecinit.F90 index cd91708d..3ef58406 100644 --- a/amgprec/impl/amg_sprecinit.F90 +++ b/amgprec/impl/amg_sprecinit.F90 @@ -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 diff --git a/amgprec/impl/amg_z_hierarchy_bld.f90 b/amgprec/impl/amg_z_hierarchy_bld.F90 similarity index 90% rename from amgprec/impl/amg_z_hierarchy_bld.f90 rename to amgprec/impl/amg_z_hierarchy_bld.F90 index a009759c..9da2736a 100644 --- a/amgprec/impl/amg_z_hierarchy_bld.f90 +++ b/amgprec/impl/amg_z_hierarchy_bld.F90 @@ -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 diff --git a/amgprec/impl/amg_z_smoothers_bld.f90 b/amgprec/impl/amg_z_smoothers_bld.f90 index 95293993..eeaef05b 100644 --- a/amgprec/impl/amg_z_smoothers_bld.f90 +++ b/amgprec/impl/amg_z_smoothers_bld.f90 @@ -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) diff --git a/amgprec/impl/amg_zcprecset.F90 b/amgprec/impl/amg_zcprecset.F90 index edaed4aa..37c67df2 100644 --- a/amgprec/impl/amg_zcprecset.F90 +++ b/amgprec/impl/amg_zcprecset.F90 @@ -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_) diff --git a/amgprec/impl/amg_zfile_prec_descr.f90 b/amgprec/impl/amg_zfile_prec_descr.f90 index f3002cfd..54e687bf 100644 --- a/amgprec/impl/amg_zfile_prec_descr.f90 +++ b/amgprec/impl/amg_zfile_prec_descr.f90 @@ -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 diff --git a/amgprec/impl/amg_zfile_prec_memory_use.f90 b/amgprec/impl/amg_zfile_prec_memory_use.f90 new file mode 100644 index 00000000..145ce044 --- /dev/null +++ b/amgprec/impl/amg_zfile_prec_memory_use.f90 @@ -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 diff --git a/amgprec/impl/amg_zprecinit.F90 b/amgprec/impl/amg_zprecinit.F90 index 9bef4d1a..ab88c80c 100644 --- a/amgprec/impl/amg_zprecinit.F90 +++ b/amgprec/impl/amg_zprecinit.F90 @@ -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 diff --git a/amgprec/impl/level/Makefile b/amgprec/impl/level/Makefile index 4ea569bd..e7542084 100644 --- a/amgprec/impl/level/Makefile +++ b/amgprec/impl/level/Makefile @@ -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 \ diff --git a/amgprec/impl/level/amg_c_base_onelev_csetc.F90 b/amgprec/impl/level/amg_c_base_onelev_csetc.F90 index 99187cdf..fc947ef4 100644 --- a/amgprec/impl/level/amg_c_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_csetc.F90 @@ -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) diff --git a/amgprec/impl/level/amg_c_base_onelev_cseti.F90 b/amgprec/impl/level/amg_c_base_onelev_cseti.F90 index deba9001..1cc22cd9 100644 --- a/amgprec/impl/level/amg_c_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_cseti.F90 @@ -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 diff --git a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 new file mode 100644 index 00000000..71719304 --- /dev/null +++ b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 @@ -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 diff --git a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 index e3e9b31c..9e7bc7c8 100644 --- a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 @@ -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) diff --git a/amgprec/impl/level/amg_d_base_onelev_cseti.F90 b/amgprec/impl/level/amg_d_base_onelev_cseti.F90 index b5ca549b..c60ff895 100644 --- a/amgprec/impl/level/amg_d_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_cseti.F90 @@ -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 diff --git a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 new file mode 100644 index 00000000..3edc5999 --- /dev/null +++ b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 @@ -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 diff --git a/amgprec/impl/level/amg_s_base_onelev_csetc.F90 b/amgprec/impl/level/amg_s_base_onelev_csetc.F90 index 5f3852bc..f660e357 100644 --- a/amgprec/impl/level/amg_s_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_csetc.F90 @@ -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) diff --git a/amgprec/impl/level/amg_s_base_onelev_cseti.F90 b/amgprec/impl/level/amg_s_base_onelev_cseti.F90 index 1211a662..74fb3899 100644 --- a/amgprec/impl/level/amg_s_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_cseti.F90 @@ -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 diff --git a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 new file mode 100644 index 00000000..8cc5a4fa --- /dev/null +++ b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 @@ -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 diff --git a/amgprec/impl/level/amg_z_base_onelev_csetc.F90 b/amgprec/impl/level/amg_z_base_onelev_csetc.F90 index f2a54a8c..6b7b9f00 100644 --- a/amgprec/impl/level/amg_z_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_csetc.F90 @@ -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) diff --git a/amgprec/impl/level/amg_z_base_onelev_cseti.F90 b/amgprec/impl/level/amg_z_base_onelev_cseti.F90 index b6a447a4..f50a785f 100644 --- a/amgprec/impl/level/amg_z_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_cseti.F90 @@ -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 diff --git a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 new file mode 100644 index 00000000..6682ff2d --- /dev/null +++ b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 @@ -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 diff --git a/amgprec/impl/smoother/Makefile b/amgprec/impl/smoother/Makefile index f26b8f00..89a1906e 100644 --- a/amgprec/impl/smoother/Makefile +++ b/amgprec/impl/smoother/Makefile @@ -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 \ diff --git a/amgprec/impl/smoother/amg_c_jac_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_c_jac_smoother_apply_vect.f90 index 040f9fb3..a4238980 100644 --- a/amgprec/impl/smoother/amg_c_jac_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_c_jac_smoother_apply_vect.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_jac_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_jac_smoother_apply_vect.f90 index 7f91b358..cafb6c8c 100644 --- a/amgprec/impl/smoother/amg_d_jac_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_jac_smoother_apply_vect.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 new file mode 100644 index 00000000..3c181841 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 new file mode 100644 index 00000000..dd156912 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_clear_data.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_clear_data.f90 new file mode 100644 index 00000000..a6df5486 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_clear_data.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_clone.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_clone.f90 new file mode 100644 index 00000000..7dfb2655 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_clone.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90 new file mode 100644 index 00000000..d72cce67 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_cnv.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_cnv.f90 new file mode 100644 index 00000000..42d2ce15 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_cnv.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 new file mode 100644 index 00000000..3d0ac0fe --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 new file mode 100644 index 00000000..916fb5e6 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90 new file mode 100644 index 00000000..f1987a7b --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90 @@ -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 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_dmp.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_dmp.f90 new file mode 100644 index 00000000..19144f07 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_dmp.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_s_jac_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_s_jac_smoother_apply_vect.f90 index 9fe3888a..fff7ac1e 100644 --- a/amgprec/impl/smoother/amg_s_jac_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_s_jac_smoother_apply_vect.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 new file mode 100644 index 00000000..de05bedb --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 new file mode 100644 index 00000000..09b01248 --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_clear_data.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_clear_data.f90 new file mode 100644 index 00000000..5b0d88b7 --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_clear_data.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_clone.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_clone.f90 new file mode 100644 index 00000000..7bf3fbcc --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_clone.f90 @@ -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 diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_clone_settings.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_clone_settings.f90 new file mode 100644 index 00000000..ddbad88f --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_clone_settings.f90 @@ -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_s_poly_smoother_clone_settings(sm,smout,info) + + use psb_base_mod + use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_clone_settings + Implicit None + ! Arguments + class(amg_s_poly_smoother_type), intent(inout) :: sm + class(amg_s_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_s_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_s_poly_smoother_clone_settings diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_cnv.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_cnv.f90 new file mode 100644 index 00000000..810809fb --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_cnv.f90 @@ -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_s_poly_smoother_cnv(sm,info,amold,vmold,imold) + + use psb_base_mod + use amg_s_diag_solver + use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_cnv + Implicit None + + ! Arguments + 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 + 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_s_poly_smoother_cnv diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_csetc.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_csetc.f90 new file mode 100644 index 00000000..b00d1d0d --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_csetc.f90 @@ -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_s_poly_smoother_csetc(sm,what,val,info,idx) + + use psb_base_mod + use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_csetc + Implicit None + ! Arguments + 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 + 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_s_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_s_poly_smoother_csetc diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_cseti.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_cseti.f90 new file mode 100644 index 00000000..78ce1b39 --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_cseti.f90 @@ -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_s_poly_smoother_cseti(sm,what,val,info,idx) + + use psb_base_mod + use amg_s_poly_smoother, amg_protect_nam => amg_s_poly_smoother_cseti + Implicit None + + ! Arguments + 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 + 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_s_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_s_poly_smoother_cseti diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_csetr.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_csetr.f90 new file mode 100644 index 00000000..c7ec74cd --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_csetr.f90 @@ -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_s_poly_smoother_csetr(sm,what,val,info,idx) + + use psb_base_mod + use amg_s_poly_smoother, amg_protect_nam => amg_s_poly_smoother_csetr + Implicit None + + ! Arguments + 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 + 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 ((szero amg_s_poly_smoother_descr + + Implicit None + + ! Arguments + 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 + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_s_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_s_poly_smoother_descr diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_dmp.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_dmp.f90 new file mode 100644 index 00000000..f6fa2f8a --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_dmp.f90 @@ -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_s_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num) + + use psb_base_mod + use amg_s_poly_smoother, amg_protect_nam => amg_s_poly_smoother_dmp + 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 + 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_s_poly_smoother_dmp diff --git a/amgprec/impl/smoother/amg_z_jac_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_z_jac_smoother_apply_vect.f90 index ac3aaf3e..16d2a484 100644 --- a/amgprec/impl/smoother/amg_z_jac_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_z_jac_smoother_apply_vect.f90 @@ -175,7 +175,7 @@ subroutine amg_z_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(zone,x,zzero,r,r,desc_data,info) + call psb_geaxpby(zone,x,zzero,r,desc_data,info) call psb_spmm(-zone,sm%pa,ty,zone,r,desc_data,info) res = psb_genrm2(r,desc_data,info) if( sm%printres ) then diff --git a/amgprec/impl/solver/amg_c_ilu_solver_bld.f90 b/amgprec/impl/solver/amg_c_ilu_solver_bld.f90 index 388afe1e..a348fcea 100644 --- a/amgprec/impl/solver/amg_c_ilu_solver_bld.f90 +++ b/amgprec/impl/solver/amg_c_ilu_solver_bld.f90 @@ -52,7 +52,7 @@ subroutine amg_c_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) class(psb_c_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables - integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, psb_fctype !!$ complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level @@ -97,10 +97,24 @@ subroutine amg_c_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) goto 9999 endif - + select case(sv%fact_type) + case (amg_ilu_n_) + psb_fctype = psb_ilu_n_ + case (amg_milu_n_) + psb_fctype = psb_milu_n_ + case (amg_ilu_t_) + psb_fctype = psb_ilu_t_ + case default + ! If we end up here, something was wrong up in the call chain. + info = psb_err_input_value_invalid_i_ + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ithree,sv%fact_type,izero,izero,izero/)) + goto 9999 + end select + select case(sv%fact_type) - case (psb_ilu_t_) + case (amg_ilu_t_) ! ! ILU(k,t) ! @@ -124,7 +138,7 @@ subroutine amg_c_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) goto 9999 end if - case(psb_ilu_n_,psb_milu_n_) + case(amg_ilu_n_,amg_milu_n_) ! ! ILU(k) and MILU(k) ! @@ -140,17 +154,17 @@ subroutine amg_c_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! There seems to be a problem with the separate implementation of MILU(0), ! contained into psb_ilu0_fact. This must be investigated. For the time being, ! resort to the implementation of MILU(k) with k=0. - if (sv%fact_type == psb_ilu_n_) then - call psb_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + if (sv%fact_type == amg_ilu_n_) then + call psb_ilu0_fact(psb_fctype,a,sv%l,sv%u,& & sv%d,info,blck=b) else - call psb_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,psb_fctype,& & a,sv%l,sv%u,sv%d,info,blck=b) endif case(1:) ! Fill-in >= 1 ! The same routine implements both ILU(k) and MILU(k) - call psb_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,psb_fctype,& & a,sv%l,sv%u,sv%d,info,blck=b) end select if (info /= psb_success_) then diff --git a/amgprec/impl/solver/amg_d_ilu_solver_bld.f90 b/amgprec/impl/solver/amg_d_ilu_solver_bld.f90 index 510ea26a..7a49e47e 100644 --- a/amgprec/impl/solver/amg_d_ilu_solver_bld.f90 +++ b/amgprec/impl/solver/amg_d_ilu_solver_bld.f90 @@ -52,7 +52,7 @@ subroutine amg_d_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) 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_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, psb_fctype !!$ real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level @@ -97,10 +97,24 @@ subroutine amg_d_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) goto 9999 endif - + select case(sv%fact_type) + case (amg_ilu_n_) + psb_fctype = psb_ilu_n_ + case (amg_milu_n_) + psb_fctype = psb_milu_n_ + case (amg_ilu_t_) + psb_fctype = psb_ilu_t_ + case default + ! If we end up here, something was wrong up in the call chain. + info = psb_err_input_value_invalid_i_ + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ithree,sv%fact_type,izero,izero,izero/)) + goto 9999 + end select + select case(sv%fact_type) - case (psb_ilu_t_) + case (amg_ilu_t_) ! ! ILU(k,t) ! @@ -124,7 +138,7 @@ subroutine amg_d_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) goto 9999 end if - case(psb_ilu_n_,psb_milu_n_) + case(amg_ilu_n_,amg_milu_n_) ! ! ILU(k) and MILU(k) ! @@ -140,17 +154,17 @@ subroutine amg_d_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! There seems to be a problem with the separate implementation of MILU(0), ! contained into psb_ilu0_fact. This must be investigated. For the time being, ! resort to the implementation of MILU(k) with k=0. - if (sv%fact_type == psb_ilu_n_) then - call psb_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + if (sv%fact_type == amg_ilu_n_) then + call psb_ilu0_fact(psb_fctype,a,sv%l,sv%u,& & sv%d,info,blck=b) else - call psb_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,psb_fctype,& & a,sv%l,sv%u,sv%d,info,blck=b) endif case(1:) ! Fill-in >= 1 ! The same routine implements both ILU(k) and MILU(k) - call psb_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,psb_fctype,& & a,sv%l,sv%u,sv%d,info,blck=b) end select if (info /= psb_success_) then diff --git a/amgprec/impl/solver/amg_s_ilu_solver_bld.f90 b/amgprec/impl/solver/amg_s_ilu_solver_bld.f90 index 4516b134..6c36bec2 100644 --- a/amgprec/impl/solver/amg_s_ilu_solver_bld.f90 +++ b/amgprec/impl/solver/amg_s_ilu_solver_bld.f90 @@ -52,7 +52,7 @@ subroutine amg_s_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) class(psb_s_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables - integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, psb_fctype !!$ real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level @@ -97,10 +97,24 @@ subroutine amg_s_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) goto 9999 endif - + select case(sv%fact_type) + case (amg_ilu_n_) + psb_fctype = psb_ilu_n_ + case (amg_milu_n_) + psb_fctype = psb_milu_n_ + case (amg_ilu_t_) + psb_fctype = psb_ilu_t_ + case default + ! If we end up here, something was wrong up in the call chain. + info = psb_err_input_value_invalid_i_ + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ithree,sv%fact_type,izero,izero,izero/)) + goto 9999 + end select + select case(sv%fact_type) - case (psb_ilu_t_) + case (amg_ilu_t_) ! ! ILU(k,t) ! @@ -124,7 +138,7 @@ subroutine amg_s_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) goto 9999 end if - case(psb_ilu_n_,psb_milu_n_) + case(amg_ilu_n_,amg_milu_n_) ! ! ILU(k) and MILU(k) ! @@ -140,17 +154,17 @@ subroutine amg_s_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! There seems to be a problem with the separate implementation of MILU(0), ! contained into psb_ilu0_fact. This must be investigated. For the time being, ! resort to the implementation of MILU(k) with k=0. - if (sv%fact_type == psb_ilu_n_) then - call psb_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + if (sv%fact_type == amg_ilu_n_) then + call psb_ilu0_fact(psb_fctype,a,sv%l,sv%u,& & sv%d,info,blck=b) else - call psb_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,psb_fctype,& & a,sv%l,sv%u,sv%d,info,blck=b) endif case(1:) ! Fill-in >= 1 ! The same routine implements both ILU(k) and MILU(k) - call psb_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,psb_fctype,& & a,sv%l,sv%u,sv%d,info,blck=b) end select if (info /= psb_success_) then diff --git a/amgprec/impl/solver/amg_z_ilu_solver_bld.f90 b/amgprec/impl/solver/amg_z_ilu_solver_bld.f90 index aead8d16..36c91ad8 100644 --- a/amgprec/impl/solver/amg_z_ilu_solver_bld.f90 +++ b/amgprec/impl/solver/amg_z_ilu_solver_bld.f90 @@ -52,7 +52,7 @@ subroutine amg_z_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) class(psb_z_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables - integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, psb_fctype !!$ complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level @@ -97,10 +97,24 @@ subroutine amg_z_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) goto 9999 endif - + select case(sv%fact_type) + case (amg_ilu_n_) + psb_fctype = psb_ilu_n_ + case (amg_milu_n_) + psb_fctype = psb_milu_n_ + case (amg_ilu_t_) + psb_fctype = psb_ilu_t_ + case default + ! If we end up here, something was wrong up in the call chain. + info = psb_err_input_value_invalid_i_ + call psb_errpush(psb_err_input_value_invalid_i_,name,& + & i_err=(/ithree,sv%fact_type,izero,izero,izero/)) + goto 9999 + end select + select case(sv%fact_type) - case (psb_ilu_t_) + case (amg_ilu_t_) ! ! ILU(k,t) ! @@ -124,7 +138,7 @@ subroutine amg_z_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) goto 9999 end if - case(psb_ilu_n_,psb_milu_n_) + case(amg_ilu_n_,amg_milu_n_) ! ! ILU(k) and MILU(k) ! @@ -140,17 +154,17 @@ subroutine amg_z_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! There seems to be a problem with the separate implementation of MILU(0), ! contained into psb_ilu0_fact. This must be investigated. For the time being, ! resort to the implementation of MILU(k) with k=0. - if (sv%fact_type == psb_ilu_n_) then - call psb_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + if (sv%fact_type == amg_ilu_n_) then + call psb_ilu0_fact(psb_fctype,a,sv%l,sv%u,& & sv%d,info,blck=b) else - call psb_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,psb_fctype,& & a,sv%l,sv%u,sv%d,info,blck=b) endif case(1:) ! Fill-in >= 1 ! The same routine implements both ILU(k) and MILU(k) - call psb_iluk_fact(sv%fill_in,sv%fact_type,& + call psb_iluk_fact(sv%fill_in,psb_fctype,& & a,sv%l,sv%u,sv%d,info,blck=b) end select if (info /= psb_success_) then diff --git a/samples/advanced/pdegen/amg_d_pde2d.F90 b/samples/advanced/pdegen/amg_d_pde2d.F90 index 8f1a3411..eca863da 100644 --- a/samples/advanced/pdegen/amg_d_pde2d.F90 +++ b/samples/advanced/pdegen/amg_d_pde2d.F90 @@ -126,24 +126,26 @@ program amg_d_pde2d ! AMG cycles for ML ! general AMG data character(len=32) :: mlcycle ! AMG cycle type - integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner + integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner ! AMG aggregation character(len=32) :: aggr_prol ! aggregation type: SMOOTHED, NONSMOOTHED character(len=32) :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC - character(len=32) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP - integer(psb_ipk_) :: aggr_size ! Requested size of the aggregates for MATCHBOXP - character(len=32) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE - character(len=32) :: aggr_filter ! filtering: FILTER, NO_FILTER - real(psb_dpk_) :: mncrratio ! minimum aggregation ratio + character(len=32) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP + integer(psb_ipk_) :: aggr_size ! Requested size of the aggregates for MATCHBOXP + character(len=32) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE + character(len=32) :: aggr_filter ! filtering: FILTER, NO_FILTER + real(psb_dpk_) :: mncrratio ! minimum aggregation ratio real(psb_dpk_), allocatable :: athresv(:) ! smoothed aggregation threshold vector - integer(psb_ipk_) :: thrvsz ! size of threshold vector - real(psb_dpk_) :: athres ! smoothed aggregation threshold - integer(psb_ipk_) :: csizepp ! minimum size of coarsest matrix per process + integer(psb_ipk_) :: thrvsz ! size of threshold vector + real(psb_dpk_) :: athres ! smoothed aggregation threshold + integer(psb_ipk_) :: csizepp ! minimum size of coarsest matrix per process ! AMG smoother or pre-smoother; also 1-lev preconditioner character(len=32) :: smther ! (pre-)smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps ! (pre-)smoother / 1-lev prec. sweeps + integer(psb_ipk_) :: degree ! degree for polynomial smoother + character(len=32) :: pvariant ! polynomial variant integer(psb_ipk_) :: novr ! number of overlap layers character(len=32) :: restr ! restriction over application of AS character(len=32) :: prol ! prolongation over application of AS @@ -158,6 +160,8 @@ program amg_d_pde2d ! AMG post-smoother; ignored by 1-lev preconditioner character(len=32) :: smther2 ! post-smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps2 ! post-smoother sweeps + integer(psb_ipk_) :: degree2 ! degree for polynomial smoother + character(len=32) :: pvariant2 ! polynomial variant integer(psb_ipk_) :: novr2 ! number of overlap layers character(len=32) :: restr2 ! restriction over application of AS character(len=32) :: prol2 ! prolongation over application of AS @@ -170,15 +174,15 @@ program amg_d_pde2d real(psb_dpk_) :: thr2 ! threshold for ILUT factorization ! coarsest-level solver - character(len=32) :: cmat ! coarsest matrix layout: REPL, DIST - character(len=32) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. - ! mat.); UMF, MUMPS, SLU, ILU, ILUT, MILU - ! (repl. mat.) - character(len=32) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT, - ! MILU, UMF, MUMPS, SLU - integer(psb_ipk_) :: cfill ! fill-in for incomplete LU factorization - real(psb_dpk_) :: cthres ! threshold for ILUT factorization - integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver + character(len=32) :: cmat ! coarsest matrix layout: REPL, DIST + character(len=32) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. + ! mat.); UMF, MUMPS, SLU, ILU, ILUT, MILU + ! (repl. mat.) + character(len=32) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT, + ! MILU, UMF, MUMPS, SLU + integer(psb_ipk_) :: cfill ! fill-in for incomplete LU factorization + real(psb_dpk_) :: cthres ! threshold for ILUT factorization + integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver ! Dump data logical :: dump = .false. @@ -285,10 +289,12 @@ program amg_d_pde2d ! 1-level sweeps from "outer_sweeps" call prec%set('smoother_sweeps', p_choice%jsweeps, info) - case ('BJAC') + case ('BJAC','POLY') call prec%set('smoother_sweeps', p_choice%jsweeps, info) call prec%set('sub_solve', p_choice%solve, info) call prec%set('solver_sweeps', p_choice%ssweeps, info) + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%pvariant, info) if (psb_toupper(p_choice%solve)=='MUMPS') & & call prec%set('mumps_loc_glob','local_solver',info) call prec%set('sub_fillin', p_choice%fill, info) @@ -312,7 +318,7 @@ program amg_d_pde2d call prec%set('ml_cycle', p_choice%mlcycle, info) call prec%set('outer_sweeps', p_choice%outer_sweeps,info) if (p_choice%csizepp>0)& - & call prec%set('min_coarse_size_per_process', p_choice%csizepp, info) + & call prec%set('min_coarse_size_per_process', p_choice%csizepp, info) if (p_choice%mncrratio>1)& & call prec%set('min_cr_ratio', p_choice%mncrratio, info) if (p_choice%maxlevs>0)& @@ -336,7 +342,9 @@ program amg_d_pde2d call prec%set('smoother_type', p_choice%smther, info) call prec%set('smoother_sweeps', p_choice%jsweeps, info) - + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%pvariant, info) + select case (psb_toupper(p_choice%smther)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -366,6 +374,8 @@ program amg_d_pde2d if (psb_toupper(p_choice%smther2) /= 'NONE') then call prec%set('smoother_type', p_choice%smther2, info,pos='post') call prec%set('smoother_sweeps', p_choice%jsweeps2, info,pos='post') + call prec%set('poly_degree', p_choice%degree2, info,pos='post') + call prec%set('poly_variant', p_choice%pvariant2, info,pos='post') select case (psb_toupper(p_choice%smther2)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -581,6 +591,8 @@ contains ! First smoother / 1-lev preconditioner call read_data(prec%smther,inp_unit) ! smoother type call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps + call read_data(prec%degree,inp_unit) ! (pre-)smoother / 1-lev prec sweeps + call read_data(prec%pvariant,inp_unit) ! call read_data(prec%novr,inp_unit) ! number of overlap layers call read_data(prec%restr,inp_unit) ! restriction over application of AS call read_data(prec%prol,inp_unit) ! prolongation over application of AS @@ -593,11 +605,13 @@ contains ! Second smoother/ AMG post-smoother (if NONE ignored in main) call read_data(prec%smther2,inp_unit) ! smoother type call read_data(prec%jsweeps2,inp_unit) ! (post-)smoother sweeps + call read_data(prec%degree2,inp_unit) ! (post-)smoother sweeps + call read_data(prec%pvariant2,inp_unit) ! call read_data(prec%novr2,inp_unit) ! number of overlap layers call read_data(prec%restr2,inp_unit) ! restriction over application of AS call read_data(prec%prol2,inp_unit) ! prolongation over application of AS call read_data(prec%solve2,inp_unit) ! local subsolver - call read_data(prec%ssweeps2,inp_unit) ! inner solver sweeps + call read_data(prec%ssweeps2,inp_unit) ! inner solver sweeps call read_data(prec%variant2,inp_unit) ! AINV variant call read_data(prec%fill2,inp_unit) ! fill-in for incomplete LU call read_data(prec%invfill2,inp_unit) !Inverse fill-in for INVK @@ -663,6 +677,8 @@ contains ! broadcast first (pre-)smoother / 1-lev prec data call psb_bcast(ctxt,prec%smther) call psb_bcast(ctxt,prec%jsweeps) + call psb_bcast(ctxt,prec%degree) + call psb_bcast(ctxt,prec%pvariant) call psb_bcast(ctxt,prec%novr) call psb_bcast(ctxt,prec%restr) call psb_bcast(ctxt,prec%prol) @@ -675,6 +691,8 @@ contains ! broadcast second (post-)smoother call psb_bcast(ctxt,prec%smther2) call psb_bcast(ctxt,prec%jsweeps2) + call psb_bcast(ctxt,prec%degree2) + call psb_bcast(ctxt,prec%pvariant2) call psb_bcast(ctxt,prec%novr2) call psb_bcast(ctxt,prec%restr2) call psb_bcast(ctxt,prec%prol2) diff --git a/samples/advanced/pdegen/amg_d_pde3d.F90 b/samples/advanced/pdegen/amg_d_pde3d.F90 index 031179fe..8c4b7b6b 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.F90 +++ b/samples/advanced/pdegen/amg_d_pde3d.F90 @@ -145,6 +145,8 @@ program amg_d_pde3d ! AMG smoother or pre-smoother; also 1-lev preconditioner character(len=32) :: smther ! (pre-)smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps ! (pre-)smoother / 1-lev prec. sweeps + integer(psb_ipk_) :: degree ! degree for polynomial smoother + character(len=32) :: pvariant ! polynomial variant integer(psb_ipk_) :: novr ! number of overlap layers character(len=32) :: restr ! restriction over application of AS character(len=32) :: prol ! prolongation over application of AS @@ -159,6 +161,8 @@ program amg_d_pde3d ! AMG post-smoother; ignored by 1-lev preconditioner character(len=32) :: smther2 ! post-smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps2 ! post-smoother sweeps + integer(psb_ipk_) :: degree2 ! degree for polynomial smoother + character(len=32) :: pvariant2 ! polynomial variant integer(psb_ipk_) :: novr2 ! number of overlap layers character(len=32) :: restr2 ! restriction over application of AS character(len=32) :: prol2 ! prolongation over application of AS @@ -198,7 +202,7 @@ program amg_d_pde3d ! other variables integer(psb_ipk_) :: info, i, k character(len=20) :: name,ch_err - type(psb_d_csr_sparse_mat) :: amold + info=psb_success_ @@ -289,10 +293,12 @@ program amg_d_pde3d ! 1-level sweeps from "outer_sweeps" call prec%set('smoother_sweeps', p_choice%jsweeps, info) - case ('BJAC') + case ('BJAC','POLY') call prec%set('smoother_sweeps', p_choice%jsweeps, info) call prec%set('sub_solve', p_choice%solve, info) call prec%set('solver_sweeps', p_choice%ssweeps, info) + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%pvariant, info) if (psb_toupper(p_choice%solve)=='MUMPS') & & call prec%set('mumps_loc_glob','local_solver',info) call prec%set('sub_fillin', p_choice%fill, info) @@ -340,7 +346,9 @@ program amg_d_pde3d call prec%set('smoother_type', p_choice%smther, info) call prec%set('smoother_sweeps', p_choice%jsweeps, info) - + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%pvariant, info) + select case (psb_toupper(p_choice%smther)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -370,6 +378,8 @@ program amg_d_pde3d if (psb_toupper(p_choice%smther2) /= 'NONE') then call prec%set('smoother_type', p_choice%smther2, info,pos='post') call prec%set('smoother_sweeps', p_choice%jsweeps2, info,pos='post') + call prec%set('poly_degree', p_choice%degree2, info,pos='post') + call prec%set('poly_variant', p_choice%pvariant2, info,pos='post') select case (psb_toupper(p_choice%smther2)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -418,7 +428,7 @@ program amg_d_pde3d end if call psb_barrier(ctxt) t1 = psb_wtime() - call prec%smoothers_build(a,desc_a,info,amold=amold) + call prec%smoothers_build(a,desc_a,info) tprec = psb_wtime()-t1 if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_smoothers_bld') @@ -585,6 +595,8 @@ contains ! First smoother / 1-lev preconditioner call read_data(prec%smther,inp_unit) ! smoother type call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps + call read_data(prec%degree,inp_unit) ! (pre-)smoother / 1-lev prec sweeps + call read_data(prec%pvariant,inp_unit) ! call read_data(prec%novr,inp_unit) ! number of overlap layers call read_data(prec%restr,inp_unit) ! restriction over application of AS call read_data(prec%prol,inp_unit) ! prolongation over application of AS @@ -597,11 +609,13 @@ contains ! Second smoother/ AMG post-smoother (if NONE ignored in main) call read_data(prec%smther2,inp_unit) ! smoother type call read_data(prec%jsweeps2,inp_unit) ! (post-)smoother sweeps + call read_data(prec%degree2,inp_unit) ! (post-)smoother sweeps + call read_data(prec%pvariant2,inp_unit) ! call read_data(prec%novr2,inp_unit) ! number of overlap layers call read_data(prec%restr2,inp_unit) ! restriction over application of AS call read_data(prec%prol2,inp_unit) ! prolongation over application of AS call read_data(prec%solve2,inp_unit) ! local subsolver - call read_data(prec%ssweeps2,inp_unit) ! inner solver sweeps + call read_data(prec%ssweeps2,inp_unit) ! inner solver sweeps call read_data(prec%variant2,inp_unit) ! AINV variant call read_data(prec%fill2,inp_unit) ! fill-in for incomplete LU call read_data(prec%invfill2,inp_unit) !Inverse fill-in for INVK @@ -667,6 +681,8 @@ contains ! broadcast first (pre-)smoother / 1-lev prec data call psb_bcast(ctxt,prec%smther) call psb_bcast(ctxt,prec%jsweeps) + call psb_bcast(ctxt,prec%degree) + call psb_bcast(ctxt,prec%pvariant) call psb_bcast(ctxt,prec%novr) call psb_bcast(ctxt,prec%restr) call psb_bcast(ctxt,prec%prol) @@ -679,6 +695,8 @@ contains ! broadcast second (post-)smoother call psb_bcast(ctxt,prec%smther2) call psb_bcast(ctxt,prec%jsweeps2) + call psb_bcast(ctxt,prec%degree2) + call psb_bcast(ctxt,prec%pvariant2) call psb_bcast(ctxt,prec%novr2) call psb_bcast(ctxt,prec%restr2) call psb_bcast(ctxt,prec%prol2) diff --git a/samples/advanced/pdegen/amg_s_pde2d.F90 b/samples/advanced/pdegen/amg_s_pde2d.F90 index 3d631a06..bcc995ea 100644 --- a/samples/advanced/pdegen/amg_s_pde2d.F90 +++ b/samples/advanced/pdegen/amg_s_pde2d.F90 @@ -126,24 +126,26 @@ program amg_s_pde2d ! AMG cycles for ML ! general AMG data character(len=32) :: mlcycle ! AMG cycle type - integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner + integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner ! AMG aggregation character(len=32) :: aggr_prol ! aggregation type: SMOOTHED, NONSMOOTHED character(len=32) :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC - character(len=32) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP - integer(psb_ipk_) :: aggr_size ! Requested size of the aggregates for MATCHBOXP - character(len=32) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE - character(len=32) :: aggr_filter ! filtering: FILTER, NO_FILTER - real(psb_spk_) :: mncrratio ! minimum aggregation ratio + character(len=32) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP + integer(psb_ipk_) :: aggr_size ! Requested size of the aggregates for MATCHBOXP + character(len=32) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE + character(len=32) :: aggr_filter ! filtering: FILTER, NO_FILTER + real(psb_spk_) :: mncrratio ! minimum aggregation ratio real(psb_spk_), allocatable :: athresv(:) ! smoothed aggregation threshold vector - integer(psb_ipk_) :: thrvsz ! size of threshold vector - real(psb_spk_) :: athres ! smoothed aggregation threshold - integer(psb_ipk_) :: csizepp ! minimum size of coarsest matrix per process + integer(psb_ipk_) :: thrvsz ! size of threshold vector + real(psb_spk_) :: athres ! smoothed aggregation threshold + integer(psb_ipk_) :: csizepp ! minimum size of coarsest matrix per process ! AMG smoother or pre-smoother; also 1-lev preconditioner character(len=32) :: smther ! (pre-)smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps ! (pre-)smoother / 1-lev prec. sweeps + integer(psb_ipk_) :: degree ! degree for polynomial smoother + character(len=32) :: pvariant ! polynomial variant integer(psb_ipk_) :: novr ! number of overlap layers character(len=32) :: restr ! restriction over application of AS character(len=32) :: prol ! prolongation over application of AS @@ -158,6 +160,8 @@ program amg_s_pde2d ! AMG post-smoother; ignored by 1-lev preconditioner character(len=32) :: smther2 ! post-smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps2 ! post-smoother sweeps + integer(psb_ipk_) :: degree2 ! degree for polynomial smoother + character(len=32) :: pvariant2 ! polynomial variant integer(psb_ipk_) :: novr2 ! number of overlap layers character(len=32) :: restr2 ! restriction over application of AS character(len=32) :: prol2 ! prolongation over application of AS @@ -170,15 +174,15 @@ program amg_s_pde2d real(psb_spk_) :: thr2 ! threshold for ILUT factorization ! coarsest-level solver - character(len=32) :: cmat ! coarsest matrix layout: REPL, DIST - character(len=32) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. - ! mat.); UMF, MUMPS, SLU, ILU, ILUT, MILU - ! (repl. mat.) - character(len=32) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT, - ! MILU, UMF, MUMPS, SLU - integer(psb_ipk_) :: cfill ! fill-in for incomplete LU factorization - real(psb_spk_) :: cthres ! threshold for ILUT factorization - integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver + character(len=32) :: cmat ! coarsest matrix layout: REPL, DIST + character(len=32) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. + ! mat.); UMF, MUMPS, SLU, ILU, ILUT, MILU + ! (repl. mat.) + character(len=32) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT, + ! MILU, UMF, MUMPS, SLU + integer(psb_ipk_) :: cfill ! fill-in for incomplete LU factorization + real(psb_spk_) :: cthres ! threshold for ILUT factorization + integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver ! Dump data logical :: dump = .false. @@ -285,10 +289,12 @@ program amg_s_pde2d ! 1-level sweeps from "outer_sweeps" call prec%set('smoother_sweeps', p_choice%jsweeps, info) - case ('BJAC') + case ('BJAC','POLY') call prec%set('smoother_sweeps', p_choice%jsweeps, info) call prec%set('sub_solve', p_choice%solve, info) call prec%set('solver_sweeps', p_choice%ssweeps, info) + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%pvariant, info) if (psb_toupper(p_choice%solve)=='MUMPS') & & call prec%set('mumps_loc_glob','local_solver',info) call prec%set('sub_fillin', p_choice%fill, info) @@ -312,7 +318,7 @@ program amg_s_pde2d call prec%set('ml_cycle', p_choice%mlcycle, info) call prec%set('outer_sweeps', p_choice%outer_sweeps,info) if (p_choice%csizepp>0)& - & call prec%set('min_coarse_size_per_process', p_choice%csizepp, info) + & call prec%set('min_coarse_size_per_process', p_choice%csizepp, info) if (p_choice%mncrratio>1)& & call prec%set('min_cr_ratio', p_choice%mncrratio, info) if (p_choice%maxlevs>0)& @@ -336,7 +342,9 @@ program amg_s_pde2d call prec%set('smoother_type', p_choice%smther, info) call prec%set('smoother_sweeps', p_choice%jsweeps, info) - + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%pvariant, info) + select case (psb_toupper(p_choice%smther)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -366,6 +374,8 @@ program amg_s_pde2d if (psb_toupper(p_choice%smther2) /= 'NONE') then call prec%set('smoother_type', p_choice%smther2, info,pos='post') call prec%set('smoother_sweeps', p_choice%jsweeps2, info,pos='post') + call prec%set('poly_degree', p_choice%degree2, info,pos='post') + call prec%set('poly_variant', p_choice%pvariant2, info,pos='post') select case (psb_toupper(p_choice%smther2)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -581,6 +591,8 @@ contains ! First smoother / 1-lev preconditioner call read_data(prec%smther,inp_unit) ! smoother type call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps + call read_data(prec%degree,inp_unit) ! (pre-)smoother / 1-lev prec sweeps + call read_data(prec%pvariant,inp_unit) ! call read_data(prec%novr,inp_unit) ! number of overlap layers call read_data(prec%restr,inp_unit) ! restriction over application of AS call read_data(prec%prol,inp_unit) ! prolongation over application of AS @@ -593,11 +605,13 @@ contains ! Second smoother/ AMG post-smoother (if NONE ignored in main) call read_data(prec%smther2,inp_unit) ! smoother type call read_data(prec%jsweeps2,inp_unit) ! (post-)smoother sweeps + call read_data(prec%degree2,inp_unit) ! (post-)smoother sweeps + call read_data(prec%pvariant2,inp_unit) ! call read_data(prec%novr2,inp_unit) ! number of overlap layers call read_data(prec%restr2,inp_unit) ! restriction over application of AS call read_data(prec%prol2,inp_unit) ! prolongation over application of AS call read_data(prec%solve2,inp_unit) ! local subsolver - call read_data(prec%ssweeps2,inp_unit) ! inner solver sweeps + call read_data(prec%ssweeps2,inp_unit) ! inner solver sweeps call read_data(prec%variant2,inp_unit) ! AINV variant call read_data(prec%fill2,inp_unit) ! fill-in for incomplete LU call read_data(prec%invfill2,inp_unit) !Inverse fill-in for INVK @@ -663,6 +677,8 @@ contains ! broadcast first (pre-)smoother / 1-lev prec data call psb_bcast(ctxt,prec%smther) call psb_bcast(ctxt,prec%jsweeps) + call psb_bcast(ctxt,prec%degree) + call psb_bcast(ctxt,prec%pvariant) call psb_bcast(ctxt,prec%novr) call psb_bcast(ctxt,prec%restr) call psb_bcast(ctxt,prec%prol) @@ -675,6 +691,8 @@ contains ! broadcast second (post-)smoother call psb_bcast(ctxt,prec%smther2) call psb_bcast(ctxt,prec%jsweeps2) + call psb_bcast(ctxt,prec%degree2) + call psb_bcast(ctxt,prec%pvariant2) call psb_bcast(ctxt,prec%novr2) call psb_bcast(ctxt,prec%restr2) call psb_bcast(ctxt,prec%prol2) diff --git a/samples/advanced/pdegen/amg_s_pde3d.F90 b/samples/advanced/pdegen/amg_s_pde3d.F90 index 0b495670..fe53cd8b 100644 --- a/samples/advanced/pdegen/amg_s_pde3d.F90 +++ b/samples/advanced/pdegen/amg_s_pde3d.F90 @@ -145,6 +145,8 @@ program amg_s_pde3d ! AMG smoother or pre-smoother; also 1-lev preconditioner character(len=32) :: smther ! (pre-)smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps ! (pre-)smoother / 1-lev prec. sweeps + integer(psb_ipk_) :: degree ! degree for polynomial smoother + character(len=32) :: pvariant ! polynomial variant integer(psb_ipk_) :: novr ! number of overlap layers character(len=32) :: restr ! restriction over application of AS character(len=32) :: prol ! prolongation over application of AS @@ -159,6 +161,8 @@ program amg_s_pde3d ! AMG post-smoother; ignored by 1-lev preconditioner character(len=32) :: smther2 ! post-smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps2 ! post-smoother sweeps + integer(psb_ipk_) :: degree2 ! degree for polynomial smoother + character(len=32) :: pvariant2 ! polynomial variant integer(psb_ipk_) :: novr2 ! number of overlap layers character(len=32) :: restr2 ! restriction over application of AS character(len=32) :: prol2 ! prolongation over application of AS @@ -198,7 +202,7 @@ program amg_s_pde3d ! other variables integer(psb_ipk_) :: info, i, k character(len=20) :: name,ch_err - type(psb_s_csr_sparse_mat) :: amold + info=psb_success_ @@ -289,10 +293,12 @@ program amg_s_pde3d ! 1-level sweeps from "outer_sweeps" call prec%set('smoother_sweeps', p_choice%jsweeps, info) - case ('BJAC') + case ('BJAC','POLY') call prec%set('smoother_sweeps', p_choice%jsweeps, info) call prec%set('sub_solve', p_choice%solve, info) call prec%set('solver_sweeps', p_choice%ssweeps, info) + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%pvariant, info) if (psb_toupper(p_choice%solve)=='MUMPS') & & call prec%set('mumps_loc_glob','local_solver',info) call prec%set('sub_fillin', p_choice%fill, info) @@ -340,7 +346,9 @@ program amg_s_pde3d call prec%set('smoother_type', p_choice%smther, info) call prec%set('smoother_sweeps', p_choice%jsweeps, info) - + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%pvariant, info) + select case (psb_toupper(p_choice%smther)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -370,6 +378,8 @@ program amg_s_pde3d if (psb_toupper(p_choice%smther2) /= 'NONE') then call prec%set('smoother_type', p_choice%smther2, info,pos='post') call prec%set('smoother_sweeps', p_choice%jsweeps2, info,pos='post') + call prec%set('poly_degree', p_choice%degree2, info,pos='post') + call prec%set('poly_variant', p_choice%pvariant2, info,pos='post') select case (psb_toupper(p_choice%smther2)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -418,7 +428,7 @@ program amg_s_pde3d end if call psb_barrier(ctxt) t1 = psb_wtime() - call prec%smoothers_build(a,desc_a,info,amold=amold) + call prec%smoothers_build(a,desc_a,info) tprec = psb_wtime()-t1 if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_smoothers_bld') @@ -585,6 +595,8 @@ contains ! First smoother / 1-lev preconditioner call read_data(prec%smther,inp_unit) ! smoother type call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps + call read_data(prec%degree,inp_unit) ! (pre-)smoother / 1-lev prec sweeps + call read_data(prec%pvariant,inp_unit) ! call read_data(prec%novr,inp_unit) ! number of overlap layers call read_data(prec%restr,inp_unit) ! restriction over application of AS call read_data(prec%prol,inp_unit) ! prolongation over application of AS @@ -597,11 +609,13 @@ contains ! Second smoother/ AMG post-smoother (if NONE ignored in main) call read_data(prec%smther2,inp_unit) ! smoother type call read_data(prec%jsweeps2,inp_unit) ! (post-)smoother sweeps + call read_data(prec%degree2,inp_unit) ! (post-)smoother sweeps + call read_data(prec%pvariant2,inp_unit) ! call read_data(prec%novr2,inp_unit) ! number of overlap layers call read_data(prec%restr2,inp_unit) ! restriction over application of AS call read_data(prec%prol2,inp_unit) ! prolongation over application of AS call read_data(prec%solve2,inp_unit) ! local subsolver - call read_data(prec%ssweeps2,inp_unit) ! inner solver sweeps + call read_data(prec%ssweeps2,inp_unit) ! inner solver sweeps call read_data(prec%variant2,inp_unit) ! AINV variant call read_data(prec%fill2,inp_unit) ! fill-in for incomplete LU call read_data(prec%invfill2,inp_unit) !Inverse fill-in for INVK @@ -667,6 +681,8 @@ contains ! broadcast first (pre-)smoother / 1-lev prec data call psb_bcast(ctxt,prec%smther) call psb_bcast(ctxt,prec%jsweeps) + call psb_bcast(ctxt,prec%degree) + call psb_bcast(ctxt,prec%pvariant) call psb_bcast(ctxt,prec%novr) call psb_bcast(ctxt,prec%restr) call psb_bcast(ctxt,prec%prol) @@ -679,6 +695,8 @@ contains ! broadcast second (post-)smoother call psb_bcast(ctxt,prec%smther2) call psb_bcast(ctxt,prec%jsweeps2) + call psb_bcast(ctxt,prec%degree2) + call psb_bcast(ctxt,prec%pvariant2) call psb_bcast(ctxt,prec%novr2) call psb_bcast(ctxt,prec%restr2) call psb_bcast(ctxt,prec%prol2) diff --git a/samples/advanced/pdegen/runs/amg_pde2d.inp b/samples/advanced/pdegen/runs/amg_pde2d.inp index 9f6a4c42..95f5f436 100644 --- a/samples/advanced/pdegen/runs/amg_pde2d.inp +++ b/samples/advanced/pdegen/runs/amg_pde2d.inp @@ -1,7 +1,7 @@ %%%%%%%%%%% General arguments % Lines starting with % are ignored. CSR ! Storage format CSR COO JAD 0200 ! IDIM; domain size. Linear system size is IDIM**2 -CONST ! PDECOEFF: CONST, EXP, BOX Coefficients of the PDE +CONST ! PDECOEFF: CONST, EXP, BOX, GAUSS Coefficients of the PDE CG ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS FCG GCR RGMRES 2 ! ISTOPC 00500 ! ITMAX @@ -9,23 +9,33 @@ CG ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS F 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS %%%%%%%%%%% Main preconditioner choices %%%%%%%%%%%%%%%% -ML-VCYCLE-BJAC-D-BJAC ! Longer descriptive name for preconditioner (up to 20 chars) -ML ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML +ML-VBM-VCYCLE-FBGS-D-BJAC ! Longer descriptive name for preconditioner (up to 20 chars) +ML ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML POLY +% %%%%%%%%%%% First smoother (for all levels but coarsest) %%%%%%%%%%%%%%%% -BJAC ! Smoother type JACOBI FBGS GS BWGS BJAC AS. For 1-level, repeats previous. -1 ! Number of sweeps for smoother +FBGS ! Smoother type JACOBI FBGS GS BWGS BJAC AS POLY r 1-level, repeats previous. +6 ! Number of sweeps for smoother +1 ! degree for polynomial smoother +POLY_LOTTES_BETA ! Polynomial variant +% Fields to be added for POLY +% POLY_RHO_ESTIMATE Currently only POLY_RHO_EST_POWER +% POLY_RHO_ESTIMATE_ITERATIONS default = 20 +% POLY_RHO_BA set to value +% 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! Subdomain solver for BJAC/AS: JACOBI GS BGS ILU ILUT MILU MUMPS SLU UMF -8 ! Inner solver sweeps (GS and JACOBI) -LLK ! AINV variant, ignored otherwise +L1-JACOBI ! Subdomain solver for BJAC/AS: JACOBI GS BGS ILU ILUT MILU MUMPS SLU UMF +1 ! Inner solver sweeps (GS and JACOBI) +LLK ! AINV variant 0 ! Fill level P for ILU(P) and ILU(T,P) 1 ! Inverse Fill level P for INVK 1.d-4 ! Threshold T for ILU(T,P) %%%%%%%%%%% Second smoother, always ignored for non-ML %%%%%%%%%%%%%%%% NONE ! Second (post) smoother, ignored if NONE -1 ! Number of sweeps for (post) smoother +6 ! Number of sweeps for (post) smoother +1 ! degree for polynomial smoother +POLY_LOTTES_BETA ! Polynomial variant 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG diff --git a/samples/advanced/pdegen/runs/amg_pde3d.inp b/samples/advanced/pdegen/runs/amg_pde3d.inp index faaae6b5..1829632b 100644 --- a/samples/advanced/pdegen/runs/amg_pde3d.inp +++ b/samples/advanced/pdegen/runs/amg_pde3d.inp @@ -1,7 +1,12 @@ %%%%%%%%%%% General arguments % Lines starting with % are ignored. CSR ! Storage format CSR COO JAD +<<<<<<< HEAD 0040 ! IDIM; domain size. Linear system size is IDIM**3 CONST ! PDECOEFF: CONST, EXP, GAUSS Coefficients of the PDE +======= +0150 ! IDIM; domain size. Linear system size is IDIM**3 +CONST ! PDECOEFF: CONST, EXP, BOX, GAUSS Coefficients of the PDE +>>>>>>> PolySmooth CG ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS FCG GCR RGMRES 2 ! ISTOPC 00008 ! ITMAX @@ -10,27 +15,44 @@ CG ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS F 1.d-6 ! EPS %%%%%%%%%%% Main preconditioner choices %%%%%%%%%%%%%%%% ML-VBM-VCYCLE-FBGS-D-BJAC ! Longer descriptive name for preconditioner (up to 20 chars) +<<<<<<< HEAD L1-JACOBI ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML %%%%%%%%%%% First smoother (for all levels but coarsest) %%%%%%%%%%%%%%%% L1-JACOBI ! Smoother type JACOBI FBGS GS BWGS BJAC AS. For 1-level, repeats previous. 4 ! Number of sweeps for smoother +======= +ML ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML POLY +% +%%%%%%%%%%% First smoother (for all levels but coarsest) %%%%%%%%%%%%%%%% +FBGS ! Smoother type JACOBI FBGS GS BWGS BJAC AS POLY r 1-level, repeats previous. +6 ! Number of sweeps for smoother +1 ! degree for polynomial smoother +POLY_LOTTES_BETA ! Polynomial variant +% Fields to be added for POLY +% POLY_RHO_ESTIMATE Currently only POLY_RHO_EST_POWER +% POLY_RHO_ESTIMATE_ITERATIONS default = 20 +% POLY_RHO_BA set to value +% +>>>>>>> PolySmooth 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -JACOBI ! Subdomain solver for BJAC/AS: JACOBI GS BGS ILU ILUT MILU MUMPS SLU UMF -8 ! Inner solver sweeps (GS and JACOBI) +L1-JACOBI ! Subdomain solver for BJAC/AS: JACOBI GS BGS ILU ILUT MILU MUMPS SLU UMF +1 ! Inner solver sweeps (GS and JACOBI) LLK ! AINV variant 0 ! Fill level P for ILU(P) and ILU(T,P) 1 ! Inverse Fill level P for INVK 1.d-4 ! Threshold T for ILU(T,P) %%%%%%%%%%% Second smoother, always ignored for non-ML %%%%%%%%%%%%%%%% NONE ! Second (post) smoother, ignored if NONE -1 ! Number of sweeps for (post) smoother +6 ! Number of sweeps for (post) smoother +1 ! degree for polynomial smoother +POLY_LOTTES_BETA ! Polynomial variant 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! Subdomain solver for BJAC/AS: JACOBI GS BGS ILU ILUT MILU MUMPS SLU UMF -8 ! Inner solver sweeps (GS and JACOBI) +L1-JACOBI ! Subdomain solver for BJAC/AS: JACOBI GS BGS ILU ILUT MILU MUMPS SLU UMF +1 ! Inner solver sweeps (GS and JACOBI) LLK ! AINV variant 0 ! Fill level P for ILU(P) and ILU(T,P) 8 ! Inverse Fill level P for INVK