From ea2f75776c7afabd345ccfc04f557476c44142ae Mon Sep 17 00:00:00 2001 From: sfilippone Date: Mon, 13 Nov 2023 16:58:30 +0100 Subject: [PATCH 01/51] Implement structure for polynomial smoother --- amgprec/Makefile | 2 + amgprec/amg_base_prec_type.F90 | 25 +- amgprec/amg_c_ilu_solver.f90 | 14 +- amgprec/amg_c_jac_solver.f90 | 5 +- amgprec/amg_d_beta_coeff_mod.f90 | 516 ++++++++++++++++++ amgprec/amg_d_ilu_solver.f90 | 14 +- amgprec/amg_d_jac_solver.f90 | 5 +- amgprec/amg_d_poly_smoother.f90 | 369 +++++++++++++ amgprec/amg_d_prec_mod.f90 | 1 + amgprec/amg_s_ilu_solver.f90 | 14 +- amgprec/amg_s_jac_solver.f90 | 5 +- amgprec/amg_z_ilu_solver.f90 | 14 +- amgprec/amg_z_jac_solver.f90 | 5 +- amgprec/impl/amg_c_smoothers_bld.f90 | 4 +- amgprec/impl/amg_ccprecset.F90 | 36 +- amgprec/impl/amg_d_smoothers_bld.f90 | 4 +- amgprec/impl/amg_dcprecset.F90 | 44 +- amgprec/impl/amg_dprecinit.F90 | 10 + amgprec/impl/amg_s_smoothers_bld.f90 | 4 +- amgprec/impl/amg_scprecset.F90 | 36 +- amgprec/impl/amg_z_smoothers_bld.f90 | 4 +- amgprec/impl/amg_zcprecset.F90 | 36 +- .../impl/level/amg_c_base_onelev_cseti.F90 | 2 +- .../impl/level/amg_d_base_onelev_csetc.F90 | 6 + .../impl/level/amg_d_base_onelev_cseti.F90 | 8 +- .../impl/level/amg_s_base_onelev_cseti.F90 | 2 +- .../impl/level/amg_z_base_onelev_cseti.F90 | 2 +- amgprec/impl/smoother/Makefile | 11 + .../smoother/amg_d_jac_smoother_clone.f90 | 1 + .../amg_d_poly_smoother_apply_vect.f90 | 357 ++++++++++++ .../impl/smoother/amg_d_poly_smoother_bld.f90 | 107 ++++ .../amg_d_poly_smoother_clear_data.f90 | 70 +++ .../smoother/amg_d_poly_smoother_clone.f90 | 90 +++ .../amg_d_poly_smoother_clone_settings.f90 | 96 ++++ .../impl/smoother/amg_d_poly_smoother_cnv.f90 | 77 +++ .../smoother/amg_d_poly_smoother_csetc.f90 | 72 +++ .../smoother/amg_d_poly_smoother_cseti.f90 | 69 +++ .../smoother/amg_d_poly_smoother_csetr.f90 | 69 +++ .../smoother/amg_d_poly_smoother_descr.f90 | 95 ++++ .../impl/smoother/amg_d_poly_smoother_dmp.f90 | 90 +++ amgprec/impl/solver/amg_c_ilu_solver_bld.f90 | 30 +- amgprec/impl/solver/amg_d_ilu_solver_bld.f90 | 30 +- amgprec/impl/solver/amg_s_ilu_solver_bld.f90 | 30 +- amgprec/impl/solver/amg_z_ilu_solver_bld.f90 | 30 +- samples/advanced/pdegen/amg_d_pde3d.F90 | 16 +- 45 files changed, 2364 insertions(+), 163 deletions(-) create mode 100644 amgprec/amg_d_beta_coeff_mod.f90 create mode 100644 amgprec/amg_d_poly_smoother.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_clear_data.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_clone.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_cnv.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 create mode 100644 amgprec/impl/smoother/amg_d_poly_smoother_dmp.f90 diff --git a/amgprec/Makefile b/amgprec/Makefile index 81e6ce8c..0442f5ac 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_beta_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 \ @@ -164,6 +165,7 @@ 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_beta_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..63f446c2 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 @@ -390,12 +391,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 ',& @@ -482,11 +483,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 +558,8 @@ contains val = amg_krm_ case('AS') val = amg_as_ + case('POLY') + val = amg_poly_ case('A_NORMI') val = amg_max_norm_ case('USER_CHOICE') @@ -1036,8 +1039,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_jac_solver.f90 b/amgprec/amg_c_jac_solver.f90 index 55335f1b..90ed85ce 100644 --- a/amgprec/amg_c_jac_solver.f90 +++ b/amgprec/amg_c_jac_solver.f90 @@ -403,7 +403,10 @@ contains info = psb_success_ call sv%a%free() - call sv%dv%free(info) + if (allocated(sv%dv)) then + call sv%dv%free(info) + deallocate(sv%dv) + end if if (allocated(sv%d)) deallocate(sv%d) call psb_erractionrestore(err_act) diff --git a/amgprec/amg_d_beta_coeff_mod.f90 b/amgprec/amg_d_beta_coeff_mod.f90 new file mode 100644 index 00000000..1bbeb876 --- /dev/null +++ b/amgprec/amg_d_beta_coeff_mod.f90 @@ -0,0 +1,516 @@ +! +! +! 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_beta_coeff_mod + use psb_base_mod + + real(psb_dpk_), parameter :: amg_d_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_beta_mat(30,30)=reshape(amg_d_beta_vect,[30,30]) + +end module amg_d_beta_coeff_mod 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_jac_solver.f90 b/amgprec/amg_d_jac_solver.f90 index 25bb1375..eb7c93ce 100644 --- a/amgprec/amg_d_jac_solver.f90 +++ b/amgprec/amg_d_jac_solver.f90 @@ -403,7 +403,10 @@ contains info = psb_success_ call sv%a%free() - call sv%dv%free(info) + if (allocated(sv%dv)) then + call sv%dv%free(info) + deallocate(sv%dv) + end if if (allocated(sv%d)) deallocate(sv%d) call psb_erractionrestore(err_act) diff --git a/amgprec/amg_d_poly_smoother.f90 b/amgprec/amg_d_poly_smoother.f90 new file mode 100644 index 00000000..aa1dd5d1 --- /dev/null +++ b/amgprec/amg_d_poly_smoother.f90 @@ -0,0 +1,369 @@ +! +! +! 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_beta_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 + type(psb_dspmat_type), pointer :: pa => null() + real(psb_dpk_), allocatable :: poly_beta(:) + real(psb_dpk_) :: rho_ba + 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 = dzero + + 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_mod.f90 b/amgprec/amg_d_prec_mod.f90 index 96e2f974..f86133d8 100644 --- a/amgprec/amg_d_prec_mod.f90 +++ b/amgprec/amg_d_prec_mod.f90 @@ -47,6 +47,7 @@ module amg_d_prec_mod use amg_d_prec_type use amg_d_jac_smoother use amg_d_as_smoother + use amg_d_poly_smoother use amg_d_id_solver use amg_d_diag_solver use amg_d_l1_diag_solver 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_jac_solver.f90 b/amgprec/amg_s_jac_solver.f90 index 8cc66bbc..0ecbd10d 100644 --- a/amgprec/amg_s_jac_solver.f90 +++ b/amgprec/amg_s_jac_solver.f90 @@ -403,7 +403,10 @@ contains info = psb_success_ call sv%a%free() - call sv%dv%free(info) + if (allocated(sv%dv)) then + call sv%dv%free(info) + deallocate(sv%dv) + end if if (allocated(sv%d)) deallocate(sv%d) call psb_erractionrestore(err_act) 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_jac_solver.f90 b/amgprec/amg_z_jac_solver.f90 index 28f1199e..5d273537 100644 --- a/amgprec/amg_z_jac_solver.f90 +++ b/amgprec/amg_z_jac_solver.f90 @@ -403,7 +403,10 @@ contains info = psb_success_ call sv%a%free() - call sv%dv%free(info) + if (allocated(sv%dv)) then + call sv%dv%free(info) + deallocate(sv%dv) + end if if (allocated(sv%d)) deallocate(sv%d) call psb_erractionrestore(err_act) 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 70dc3013..4e7c7c4e 100644 --- a/amgprec/impl/amg_ccprecset.F90 +++ b/amgprec/impl/amg_ccprecset.F90 @@ -471,7 +471,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(),& @@ -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(),& @@ -508,7 +508,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_) @@ -516,21 +516,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_) @@ -545,7 +545,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_) @@ -568,7 +568,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_) @@ -592,7 +592,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_) @@ -700,7 +700,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(),& @@ -713,7 +713,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(),& @@ -736,7 +736,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_) @@ -744,21 +744,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_) @@ -773,7 +773,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_) @@ -796,7 +796,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_) @@ -820,7 +820,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_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 deaced0d..c46f5224 100644 --- a/amgprec/impl/amg_dcprecset.F90 +++ b/amgprec/impl/amg_dcprecset.F90 @@ -81,6 +81,7 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) use amg_d_prec_mod, amg_protect_name => amg_dcprecseti use amg_d_jac_smoother use amg_d_as_smoother + use amg_d_poly_smoother use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_ilu_solver @@ -125,7 +126,7 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) info = 3111 write(psb_err_unit,*) name,& & ': Error: uninitialized preconditioner,',& - &' should call amg_PRECINIT' + & ' should call amg_PRECINIT' return endif @@ -312,6 +313,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) use amg_d_prec_mod, amg_protect_name => amg_dcprecsetc use amg_d_jac_smoother use amg_d_as_smoother + use amg_d_poly_smoother use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_ilu_solver @@ -402,6 +404,10 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) do il=ilev_, ilmax_ call p%precv(il)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) end do + case ('POLY') + do il=ilev_, ilmax_ + call p%precv(il)%set('SMOOTHER_TYPE',amg_poly_,info,pos=pos) + end do case ('L1-BJAC') do il=ilev_, ilmax_ call p%precv(il)%set('SMOOTHER_TYPE',amg_l1_bjac_,info,pos=pos) @@ -485,7 +491,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(),& @@ -501,7 +507,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(),& @@ -524,7 +530,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_) @@ -532,21 +538,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_) @@ -561,7 +567,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_) @@ -591,7 +597,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_) @@ -629,7 +635,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_) @@ -739,7 +745,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(),& @@ -754,7 +760,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(),& @@ -777,7 +783,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_) @@ -785,21 +791,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_) @@ -814,7 +820,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_) @@ -844,7 +850,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_) @@ -882,7 +888,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_dprecinit.F90 b/amgprec/impl/amg_dprecinit.F90 index eaa861e9..491d8eca 100644 --- a/amgprec/impl/amg_dprecinit.F90 +++ b/amgprec/impl/amg_dprecinit.F90 @@ -93,6 +93,7 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info) use psb_base_mod use amg_d_prec_mod, amg_protect_name => amg_dprecinit use amg_d_jac_smoother + use amg_d_poly_smoother use amg_d_as_smoother use amg_d_id_solver use amg_d_diag_solver @@ -156,6 +157,15 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info) 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_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_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 754725ad..741325fb 100644 --- a/amgprec/impl/amg_scprecset.F90 +++ b/amgprec/impl/amg_scprecset.F90 @@ -471,7 +471,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(),& @@ -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(),& @@ -508,7 +508,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_) @@ -516,21 +516,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_) @@ -545,7 +545,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_) @@ -568,7 +568,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_) @@ -592,7 +592,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_) @@ -700,7 +700,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(),& @@ -713,7 +713,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(),& @@ -736,7 +736,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_) @@ -744,21 +744,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_) @@ -773,7 +773,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_) @@ -796,7 +796,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_) @@ -820,7 +820,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_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 5317ca6c..3b63befd 100644 --- a/amgprec/impl/amg_zcprecset.F90 +++ b/amgprec/impl/amg_zcprecset.F90 @@ -485,7 +485,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(),& @@ -501,7 +501,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(),& @@ -524,7 +524,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_) @@ -532,21 +532,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_) @@ -561,7 +561,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_) @@ -591,7 +591,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_) @@ -629,7 +629,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_) @@ -739,7 +739,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(),& @@ -754,7 +754,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(),& @@ -777,7 +777,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_) @@ -785,21 +785,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_) @@ -814,7 +814,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_) @@ -844,7 +844,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_) @@ -882,7 +882,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/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_d_base_onelev_csetc.F90 b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 index 94f45276..c8a8941d 100644 --- a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 @@ -45,6 +45,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) use amg_d_parmatch_aggregator_mod use amg_d_jac_smoother use amg_d_as_smoother + use amg_d_poly_smoother use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_jac_solver @@ -84,6 +85,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold + type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold type(amg_d_jac_solver_type) :: amg_d_jac_solver_mold @@ -156,6 +158,10 @@ 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') diff --git a/amgprec/impl/level/amg_d_base_onelev_cseti.F90 b/amgprec/impl/level/amg_d_base_onelev_cseti.F90 index b5ca549b..195fbed7 100644 --- a/amgprec/impl/level/amg_d_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_cseti.F90 @@ -45,6 +45,7 @@ subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx) use amg_d_parmatch_aggregator_mod use amg_d_jac_smoother use amg_d_as_smoother + use amg_d_poly_smoother use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_ilu_solver @@ -79,6 +80,7 @@ subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx) type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold + type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold @@ -141,6 +143,10 @@ subroutine amg_d_base_onelev_cseti(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 (amg_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 (amg_fbgs_) 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') @@ -177,7 +183,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_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_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/smoother/Makefile b/amgprec/impl/smoother/Makefile index f26b8f00..58884bc8 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 \ diff --git a/amgprec/impl/smoother/amg_d_jac_smoother_clone.f90 b/amgprec/impl/smoother/amg_d_jac_smoother_clone.f90 index 21b6da06..1a084f87 100644 --- a/amgprec/impl/smoother/amg_d_jac_smoother_clone.f90 +++ b/amgprec/impl/smoother/amg_d_jac_smoother_clone.f90 @@ -72,6 +72,7 @@ subroutine amg_d_jac_smoother_clone(sm,smout,info) smo%checkiter = sm%checkiter smo%printiter = sm%printiter smo%tol = sm%tol + smo%pa => sm%pa call sm%nd%clone(smo%nd,info) if ((info==psb_success_).and.(allocated(sm%sv))) then allocate(smout%sv,mold=sm%sv,stat=info) 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..2fc3115c --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -0,0 +1,357 @@ +! +! +! 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 + 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 + ! + 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 + real(psb_dpk_) :: cz, cr + 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 + + 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 (me == 0) write(0,*) name,' Unimplemented apply_vect ' +!!$ info =psb_err_internal_error_ +!!$ call psb_errpush(info,& +!!$ & name,a_err='Error in sub_aply Polynomial not implemented') +!!$ goto 9999 + + 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() + + do i=1, sm%pdegree + call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Y') + cz = (2*i*done-3)/(2*i*done+done) + cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + call psb_geaxpby(sm%poly_beta(i),tz,done,tx,desc_data,info) + call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) + end do + + 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.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then +!!$ ! if .not.sv%is_iterative, there's no need to pass init +!!$ call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,& +!!$ & name,a_err='Error in sub_aply Jacobi Sweeps = 1') +!!$ goto 9999 +!!$ endif +!!$ +!!$ else if (sweeps >= 0) then +!!$ select type (smsv => sm%sv) +!!$ class is (amg_d_diag_solver_type) +!!$ ! +!!$ ! This means we are dealing with a pure Jacobi smoother/solver. +!!$ ! +!!$ associate(tx => wv(1), ty => wv(2)) +!!$ select case (init_) +!!$ case('Z') +!!$ +!!$ call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') +!!$ +!!$ case('Y') +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_geaxpby(done,y,dzero,ty,desc_data,info) +!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case('U') +!!$ if (.not.present(initu)) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='missing initu to smoother_apply') +!!$ goto 9999 +!!$ end if +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_geaxpby(done,initu,dzero,ty,desc_data,info) +!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case default +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='wrong init to smoother_apply') +!!$ goto 9999 +!!$ end select +!!$ +!!$ do i=1, sweeps-1 +!!$ ! +!!$ ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), +!!$ ! where is the diagonal and A the matrix. +!!$ ! +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ +!!$ if (info /= psb_success_) exit +!!$ +!!$ call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ 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_spmm(-done,sm%pa,ty,done,r,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ if( sm%printres ) then +!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) +!!$ end if +!!$ if ( res < sm%tol*resdenum ) then +!!$ if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & +!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) +!!$ exit +!!$ end if +!!$ end if +!!$ +!!$ end do +!!$ +!!$ +!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='subsolve with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ +!!$ end associate +!!$ +!!$ class default +!!$ ! +!!$ ! +!!$ ! Apply multiple sweeps of a block-Jacobi solver +!!$ ! to compute an approximate solution of a linear system. +!!$ ! +!!$ ! +!!$ if (size(wv) < 2) 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)) +!!$ +!!$ ! +!!$ ! Unroll the first iteration and fold it inside SELECT CASE +!!$ ! this will save one AXPBY and one SPMM when INIT=Z, and will be +!!$ ! significant when sweeps=1 (a common case) +!!$ ! +!!$ select case (init_) +!!$ case('Z') +!!$ +!!$ call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') +!!$ +!!$ case('Y') +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_geaxpby(done,y,dzero,ty,desc_data,info) +!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case('U') +!!$ if (.not.present(initu)) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='missing initu to smoother_apply') +!!$ goto 9999 +!!$ end if +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_geaxpby(done,initu,dzero,ty,desc_data,info) +!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case default +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='wrong init to smoother_apply') +!!$ goto 9999 +!!$ end select +!!$ +!!$ do i=1, sweeps-1 +!!$ ! +!!$ ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the +!!$ ! block diagonal part and the remaining part of the local matrix +!!$ ! and Y(j) is the approximate solution at sweep j. +!!$ ! +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ +!!$ if (info /= psb_success_) exit +!!$ +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ 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_spmm(-done,sm%pa,ty,done,r,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ if( sm%printres ) then +!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) +!!$ end if +!!$ if (res < sm%tol*resdenum ) then +!!$ if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & +!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) +!!$ exit +!!$ end if +!!$ end if +!!$ +!!$ end do +!!$ +!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='subsolve with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ end associate +!!$ end select +!!$ +!!$ else +!!$ +!!$ info = psb_err_iarg_neg_ +!!$ call psb_errpush(info,name,& +!!$ & i_err=(/itwo,sweeps,izero,izero,izero/)) +!!$ goto 9999 +!!$ +!!$ endif +!!$ + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + +!!$ if(sm%checkres) then +!!$ call psb_gefree(r,desc_data,info) +!!$ end if + + 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..be83a0ae --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -0,0 +1,107 @@ +! +! +! 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_beta_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 + 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() + + 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_beta_mat(1:sm%pdegree,sm%pdegree) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid sm%degree') + goto 9999 + end if + sm%pa => a + 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 (sm%rho_ba <= dzero) then + sm%rho_ba = psb_dspnrm1(a,desc_a,info) + 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..ac526bca --- /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='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..1fbdac37 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90 @@ -0,0 +1,96 @@ +! +! +! 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 + + 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..3c1fef00 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 @@ -0,0 +1,72 @@ +! +! +! 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_nam => 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 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..8bc48724 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 @@ -0,0 +1,69 @@ +! +! +! 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('SMOOTHER_DEGREE') + sm%pdegree = val + 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..de308a8e --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90 @@ -0,0 +1,69 @@ +! +! +! 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('RHO_BA') + sm%rho_ba = val + case default + call sm%amg_d_base_smoother_type%set(what,val,info,idx=idx) + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine amg_d_poly_smoother_csetr diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 new file mode 100644 index 00000000..d17c5aa5 --- /dev/null +++ b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 @@ -0,0 +1,95 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the AMG4PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) + + use psb_base_mod + use amg_d_diag_solver + use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_descr + use amg_d_diag_solver + use amg_d_gs_solver + + 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 ' + 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) + 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/solver/amg_c_ilu_solver_bld.f90 b/amgprec/impl/solver/amg_c_ilu_solver_bld.f90 index 388afe1e..9f6109db 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 = amg_ilu_n_ + case (amg_milu_n_) + psb_fctype = amg_milu_n_ + case (amg_ilu_t_) + psb_fctype = amg_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..c4ab246a 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 = amg_ilu_n_ + case (amg_milu_n_) + psb_fctype = amg_milu_n_ + case (amg_ilu_t_) + psb_fctype = amg_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..8cfadb3b 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 = amg_ilu_n_ + case (amg_milu_n_) + psb_fctype = amg_milu_n_ + case (amg_ilu_t_) + psb_fctype = amg_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..3afa82f7 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 = amg_ilu_n_ + case (amg_milu_n_) + psb_fctype = amg_milu_n_ + case (amg_ilu_t_) + psb_fctype = amg_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_pde3d.F90 b/samples/advanced/pdegen/amg_d_pde3d.F90 index 006c6d6f..410b6e01 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.F90 +++ b/samples/advanced/pdegen/amg_d_pde3d.F90 @@ -144,6 +144,7 @@ program amg_d_pde3d ! AMG smoother or pre-smoother; also 1-lev preconditioner character(len=16) :: smther ! (pre-)smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps ! (pre-)smoother / 1-lev prec. sweeps + integer(psb_ipk_) :: degree ! degree for polynomial smoother integer(psb_ipk_) :: novr ! number of overlap layers character(len=16) :: restr ! restriction over application of AS character(len=16) :: prol ! prolongation over application of AS @@ -158,6 +159,7 @@ program amg_d_pde3d ! AMG post-smoother; ignored by 1-lev preconditioner character(len=16) :: smther2 ! post-smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps2 ! post-smoother sweeps + integer(psb_ipk_) :: degree2 ! degree for polynomial smoother integer(psb_ipk_) :: novr2 ! number of overlap layers character(len=16) :: restr2 ! restriction over application of AS character(len=16) :: prol2 ! prolongation over application of AS @@ -285,10 +287,11 @@ 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('smoother_degree', p_choice%degree, 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) @@ -336,7 +339,8 @@ 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('smoother_degree', p_choice%degree, info) + select case (psb_toupper(p_choice%smther)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -366,6 +370,7 @@ 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('smoother_degree', p_choice%degree2, info,pos='post') select case (psb_toupper(p_choice%smther2)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -402,6 +407,7 @@ program amg_d_pde3d call prec%set('coarse_sweeps', p_choice%cjswp, info) end select +!!$ call prec%descr(info,iout=psb_out_unit) ! build the preconditioner call psb_barrier(ctxt) @@ -581,6 +587,7 @@ 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%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 +600,12 @@ 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%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 +671,7 @@ 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%novr) call psb_bcast(ctxt,prec%restr) call psb_bcast(ctxt,prec%prol) @@ -675,6 +684,7 @@ 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%novr2) call psb_bcast(ctxt,prec%restr2) call psb_bcast(ctxt,prec%prol2) From 2dd1cbd3dc1a40fb6f12d217007a741d4224f59f Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 17 Nov 2023 13:13:30 +0100 Subject: [PATCH 02/51] Fix coeff generation. Change name of polynomial coefficients module. --- ...coeff_mod.f90 => amg_d_poly_coeff_mod.f90} | 0 .../advanced/pdegen/amg_d_pde2d_base_mod.f90 | 12 +++++----- .../advanced/pdegen/amg_d_pde2d_box_mod.f90 | 12 +++++----- .../advanced/pdegen/amg_d_pde2d_exp_mod.f90 | 16 ++++++------- .../advanced/pdegen/amg_d_pde3d_base_mod.f90 | 24 +++++++++---------- .../advanced/pdegen/amg_d_pde3d_exp_mod.f90 | 18 +++++++------- .../advanced/pdegen/amg_d_pde3d_gauss_mod.f90 | 20 ++++++++-------- .../advanced/pdegen/amg_s_pde2d_base_mod.f90 | 12 +++++----- .../advanced/pdegen/amg_s_pde2d_box_mod.f90 | 12 +++++----- .../advanced/pdegen/amg_s_pde2d_exp_mod.f90 | 16 ++++++------- .../advanced/pdegen/amg_s_pde3d_base_mod.f90 | 18 +++++++------- .../advanced/pdegen/amg_s_pde3d_exp_mod.f90 | 18 +++++++------- .../advanced/pdegen/amg_s_pde3d_gauss_mod.f90 | 20 ++++++++-------- 13 files changed, 99 insertions(+), 99 deletions(-) rename amgprec/{amg_d_beta_coeff_mod.f90 => amg_d_poly_coeff_mod.f90} (100%) diff --git a/amgprec/amg_d_beta_coeff_mod.f90 b/amgprec/amg_d_poly_coeff_mod.f90 similarity index 100% rename from amgprec/amg_d_beta_coeff_mod.f90 rename to amgprec/amg_d_poly_coeff_mod.f90 diff --git a/samples/advanced/pdegen/amg_d_pde2d_base_mod.f90 b/samples/advanced/pdegen/amg_d_pde2d_base_mod.f90 index 844405ef..a406e90e 100644 --- a/samples/advanced/pdegen/amg_d_pde2d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde2d_base_mod.f90 @@ -46,37 +46,37 @@ contains ! functions parametrizing the differential equation ! function b1(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: b1 real(psb_dpk_), intent(in) :: x,y b1 = dzero/1.414_psb_dpk_ end function b1 function b2(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: b2 real(psb_dpk_), intent(in) :: x,y b2 = dzero/1.414_psb_dpk_ end function b2 function c(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: c real(psb_dpk_), intent(in) :: x,y c = dzero end function c function a1(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: a1 real(psb_dpk_), intent(in) :: x,y a1=done*epsilon end function a1 function a2(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: a2 real(psb_dpk_), intent(in) :: x,y a2=done*epsilon end function a2 function g(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: g real(psb_dpk_), intent(in) :: x,y g = dzero diff --git a/samples/advanced/pdegen/amg_d_pde2d_box_mod.f90 b/samples/advanced/pdegen/amg_d_pde2d_box_mod.f90 index 39cc66c0..db743633 100644 --- a/samples/advanced/pdegen/amg_d_pde2d_box_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde2d_box_mod.f90 @@ -46,37 +46,37 @@ contains ! functions parametrizing the differential equation ! function b1_box(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: b1_box real(psb_dpk_), intent(in) :: x,y b1_box = done/1.414_psb_dpk_ end function b1_box function b2_box(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: b2_box real(psb_dpk_), intent(in) :: x,y b2_box = done/1.414_psb_dpk_ end function b2_box function c_box(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: c_box real(psb_dpk_), intent(in) :: x,y c_box = dzero end function c_box function a1_box(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: a1_box real(psb_dpk_), intent(in) :: x,y a1_box=done*epsilon end function a1_box function a2_box(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: a2_box real(psb_dpk_), intent(in) :: x,y a2_box=done*epsilon end function a2_box function g_box(x,y) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: g_box real(psb_dpk_), intent(in) :: x,y g_box = dzero diff --git a/samples/advanced/pdegen/amg_d_pde2d_exp_mod.f90 b/samples/advanced/pdegen/amg_d_pde2d_exp_mod.f90 index 90fb8126..5dab37bc 100644 --- a/samples/advanced/pdegen/amg_d_pde2d_exp_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde2d_exp_mod.f90 @@ -46,37 +46,37 @@ contains ! functions parametrizing the differential equation ! function b1_exp(x,y) - use psb_base_mod, only : psb_dpk_, done, dzero + implicit none real(psb_dpk_) :: b1_exp real(psb_dpk_), intent(in) :: x,y b1_exp = dzero end function b1_exp function b2_exp(x,y) - use psb_base_mod, only : psb_dpk_, done, dzero + implicit none real(psb_dpk_) :: b2_exp real(psb_dpk_), intent(in) :: x,y b2_exp = dzero end function b2_exp function c_exp(x,y) - use psb_base_mod, only : psb_dpk_, done, dzero + implicit none real(psb_dpk_) :: c_exp real(psb_dpk_), intent(in) :: x,y c_exp = dzero end function c_exp function a1_exp(x,y) - use psb_base_mod, only : psb_dpk_, done, dzero + implicit none real(psb_dpk_) :: a1_exp real(psb_dpk_), intent(in) :: x,y - a1=done*epsilon*exp(-(x+y)) + a1_exp=done*epsilon*exp(-(x+y)) end function a1_exp function a2_exp(x,y) - use psb_base_mod, only : psb_dpk_, done, dzero + implicit none real(psb_dpk_) :: a2_exp real(psb_dpk_), intent(in) :: x,y - a2=done*epsilon*exp(-(x+y)) + a2_exp=done*epsilon*exp(-(x+y)) end function a2_exp function g_exp(x,y) - use psb_base_mod, only : psb_dpk_, done, dzero + implicit none real(psb_dpk_) :: g_exp real(psb_dpk_), intent(in) :: x,y g_exp = dzero diff --git a/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 b/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 index a6de1d87..0eaf0a34 100644 --- a/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 @@ -35,7 +35,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! module amg_d_pde3d_base_mod - use psb_base_mod, only : psb_dpk_, done + use psb_base_mod, only : psb_dpk_, done, dzero real(psb_dpk_), save, private :: epsilon=done/80 contains subroutine pde_set_parm(dat) @@ -46,49 +46,49 @@ contains ! functions parametrizing the differential equation ! function b1(x,y,z) - use psb_base_mod, only : psb_dpk_, done + implicit none real(psb_dpk_) :: b1 real(psb_dpk_), intent(in) :: x,y,z - b1=done/sqrt(3.0_psb_dpk_) + b1=dzero/sqrt(3.0_psb_dpk_) end function b1 function b2(x,y,z) - use psb_base_mod, only : psb_dpk_, done + implicit none real(psb_dpk_) :: b2 real(psb_dpk_), intent(in) :: x,y,z - b2=done/sqrt(3.0_psb_dpk_) + b2=dzero/sqrt(3.0_psb_dpk_) end function b2 function b3(x,y,z) - use psb_base_mod, only : psb_dpk_, done + implicit none real(psb_dpk_) :: b3 real(psb_dpk_), intent(in) :: x,y,z - b3=done/sqrt(3.0_psb_dpk_) + b3=dzero/sqrt(3.0_psb_dpk_) end function b3 function c(x,y,z) - use psb_base_mod, only : psb_dpk_, dzero, done + implicit none real(psb_dpk_) :: c real(psb_dpk_), intent(in) :: x,y,z c=dzero end function c function a1(x,y,z) - use psb_base_mod, only : psb_dpk_ + implicit none real(psb_dpk_) :: a1 real(psb_dpk_), intent(in) :: x,y,z a1=epsilon end function a1 function a2(x,y,z) - use psb_base_mod, only : psb_dpk_ + implicit none real(psb_dpk_) :: a2 real(psb_dpk_), intent(in) :: x,y,z a2=epsilon end function a2 function a3(x,y,z) - use psb_base_mod, only : psb_dpk_ + implicit none real(psb_dpk_) :: a3 real(psb_dpk_), intent(in) :: x,y,z a3=epsilon end function a3 function g(x,y,z) - use psb_base_mod, only : psb_dpk_, done, dzero + implicit none real(psb_dpk_) :: g real(psb_dpk_), intent(in) :: x,y,z g = dzero diff --git a/samples/advanced/pdegen/amg_d_pde3d_exp_mod.f90 b/samples/advanced/pdegen/amg_d_pde3d_exp_mod.f90 index e7249e6c..e7bcf6ef 100644 --- a/samples/advanced/pdegen/amg_d_pde3d_exp_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde3d_exp_mod.f90 @@ -35,7 +35,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! module amg_d_pde3d_exp_mod - use psb_base_mod, only : psb_dpk_, done + use psb_base_mod, only : psb_dpk_, done, dzero real(psb_dpk_), save, private :: epsilon=done/160 contains subroutine pde_set_parm(dat) @@ -46,49 +46,49 @@ contains ! functions parametrizing the differential equation ! function b1_exp(x,y,z) - use psb_base_mod, only : psb_dpk_, dzero + implicit none real(psb_dpk_) :: b1_exp real(psb_dpk_), intent(in) :: x,y,z b1_exp=dzero/sqrt(3.0_psb_dpk_) end function b1_exp function b2_exp(x,y,z) - use psb_base_mod, only : psb_dpk_, dzero + implicit none real(psb_dpk_) :: b2_exp real(psb_dpk_), intent(in) :: x,y,z b2_exp=dzero/sqrt(3.0_psb_dpk_) end function b2_exp function b3_exp(x,y,z) - use psb_base_mod, only : psb_dpk_, dzero + implicit none real(psb_dpk_) :: b3_exp real(psb_dpk_), intent(in) :: x,y,z b3_exp=dzero/sqrt(3.0_psb_dpk_) end function b3_exp function c_exp(x,y,z) - use psb_base_mod, only : psb_dpk_, dzero + implicit none real(psb_dpk_) :: c_exp real(psb_dpk_), intent(in) :: x,y,z c_exp=dzero end function c_exp function a1_exp(x,y,z) - use psb_base_mod, only : psb_dpk_ + implicit none real(psb_dpk_) :: a1_exp real(psb_dpk_), intent(in) :: x,y,z a1_exp=epsilon*exp(-(x+y+z)) end function a1_exp function a2_exp(x,y,z) - use psb_base_mod, only : psb_dpk_ + implicit none real(psb_dpk_) :: a2_exp real(psb_dpk_), intent(in) :: x,y,z a2_exp=epsilon*exp(-(x+y+z)) end function a2_exp function a3_exp(x,y,z) - use psb_base_mod, only : psb_dpk_ + implicit none real(psb_dpk_) :: a3_exp real(psb_dpk_), intent(in) :: x,y,z a3_exp=epsilon*exp(-(x+y+z)) end function a3_exp function g_exp(x,y,z) - use psb_base_mod, only : psb_dpk_, done, dzero + implicit none real(psb_dpk_) :: g_exp real(psb_dpk_), intent(in) :: x,y,z g_exp = dzero diff --git a/samples/advanced/pdegen/amg_d_pde3d_gauss_mod.f90 b/samples/advanced/pdegen/amg_d_pde3d_gauss_mod.f90 index 8a9eda7d..8dd5f71a 100644 --- a/samples/advanced/pdegen/amg_d_pde3d_gauss_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde3d_gauss_mod.f90 @@ -35,7 +35,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! module amg_d_pde3d_gauss_mod - use psb_base_mod, only : psb_dpk_, done + use psb_base_mod, only : psb_dpk_, done, dzero real(psb_dpk_), save, private :: epsilon=done/80 contains subroutine pde_set_parm(dat) @@ -46,49 +46,49 @@ contains ! functions parametrizing the differential equation ! function b1_gauss(x,y,z) - use psb_base_mod, only : psb_dpk_, done + implicit none real(psb_dpk_) :: b1_gauss real(psb_dpk_), intent(in) :: x,y,z b1_gauss=done/sqrt(3.0_psb_dpk_)-2*x*exp(-(x**2+y**2+z**2)) end function b1_gauss function b2_gauss(x,y,z) - use psb_base_mod, only : psb_dpk_, done + implicit none real(psb_dpk_) :: b2_gauss real(psb_dpk_), intent(in) :: x,y,z b2_gauss=done/sqrt(3.0_psb_dpk_)-2*y*exp(-(x**2+y**2+z**2)) end function b2_gauss function b3_gauss(x,y,z) - use psb_base_mod, only : psb_dpk_, done + implicit none real(psb_dpk_) :: b3_gauss real(psb_dpk_), intent(in) :: x,y,z b3_gauss=done/sqrt(3.0_psb_dpk_)-2*z*exp(-(x**2+y**2+z**2)) end function b3_gauss function c_gauss(x,y,z) - use psb_base_mod, only : psb_dpk_, dzero + implicit none real(psb_dpk_) :: c_gauss real(psb_dpk_), intent(in) :: x,y,z - c=dzero + c_gauss=dzero end function c_gauss function a1_gauss(x,y,z) - use psb_base_mod, only : psb_dpk_ + implicit none real(psb_dpk_) :: a1_gauss real(psb_dpk_), intent(in) :: x,y,z a1_gauss=epsilon*exp(-(x**2+y**2+z**2)) end function a1_gauss function a2_gauss(x,y,z) - use psb_base_mod, only : psb_dpk_ + implicit none real(psb_dpk_) :: a2_gauss real(psb_dpk_), intent(in) :: x,y,z a2_gauss=epsilon*exp(-(x**2+y**2+z**2)) end function a2_gauss function a3_gauss(x,y,z) - use psb_base_mod, only : psb_dpk_ + implicit none real(psb_dpk_) :: a3_gauss real(psb_dpk_), intent(in) :: x,y,z a3_gauss=epsilon*exp(-(x**2+y**2+z**2)) end function a3_gauss function g_gauss(x,y,z) - use psb_base_mod, only : psb_dpk_, done, dzero + implicit none real(psb_dpk_) :: g_gauss real(psb_dpk_), intent(in) :: x,y,z g_gauss = dzero diff --git a/samples/advanced/pdegen/amg_s_pde2d_base_mod.f90 b/samples/advanced/pdegen/amg_s_pde2d_base_mod.f90 index 09376a68..462c6154 100644 --- a/samples/advanced/pdegen/amg_s_pde2d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde2d_base_mod.f90 @@ -46,37 +46,37 @@ contains ! functions parametrizing the differential equation ! function b1(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: b1 real(psb_spk_), intent(in) :: x,y b1 = szero/1.414_psb_spk_ end function b1 function b2(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: b2 real(psb_spk_), intent(in) :: x,y b2 = szero/1.414_psb_spk_ end function b2 function c(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: c real(psb_spk_), intent(in) :: x,y c = szero end function c function a1(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: a1 real(psb_spk_), intent(in) :: x,y a1=sone*epsilon end function a1 function a2(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: a2 real(psb_spk_), intent(in) :: x,y a2=sone*epsilon end function a2 function g(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: g real(psb_spk_), intent(in) :: x,y g = szero diff --git a/samples/advanced/pdegen/amg_s_pde2d_box_mod.f90 b/samples/advanced/pdegen/amg_s_pde2d_box_mod.f90 index 77e92514..9183521b 100644 --- a/samples/advanced/pdegen/amg_s_pde2d_box_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde2d_box_mod.f90 @@ -46,37 +46,37 @@ contains ! functions parametrizing the differential equation ! function b1_box(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: b1_box real(psb_spk_), intent(in) :: x,y b1_box = sone/1.414_psb_spk_ end function b1_box function b2_box(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: b2_box real(psb_spk_), intent(in) :: x,y b2_box = sone/1.414_psb_spk_ end function b2_box function c_box(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: c_box real(psb_spk_), intent(in) :: x,y c_box = szero end function c_box function a1_box(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: a1_box real(psb_spk_), intent(in) :: x,y a1_box=sone*epsilon end function a1_box function a2_box(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: a2_box real(psb_spk_), intent(in) :: x,y a2_box=sone*epsilon end function a2_box function g_box(x,y) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: g_box real(psb_spk_), intent(in) :: x,y g_box = szero diff --git a/samples/advanced/pdegen/amg_s_pde2d_exp_mod.f90 b/samples/advanced/pdegen/amg_s_pde2d_exp_mod.f90 index 80d34f28..3657546d 100644 --- a/samples/advanced/pdegen/amg_s_pde2d_exp_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde2d_exp_mod.f90 @@ -46,37 +46,37 @@ contains ! functions parametrizing the differential equation ! function b1_exp(x,y) - use psb_base_mod, only : psb_spk_, sone, szero + implicit none real(psb_spk_) :: b1_exp real(psb_spk_), intent(in) :: x,y b1_exp = szero end function b1_exp function b2_exp(x,y) - use psb_base_mod, only : psb_spk_, sone, szero + implicit none real(psb_spk_) :: b2_exp real(psb_spk_), intent(in) :: x,y b2_exp = szero end function b2_exp function c_exp(x,y) - use psb_base_mod, only : psb_spk_, sone, szero + implicit none real(psb_spk_) :: c_exp real(psb_spk_), intent(in) :: x,y c_exp = szero end function c_exp function a1_exp(x,y) - use psb_base_mod, only : psb_spk_, sone, szero + implicit none real(psb_spk_) :: a1_exp real(psb_spk_), intent(in) :: x,y - a1=sone*epsilon*exp(-(x+y)) + a1_exp=sone*epsilon*exp(-(x+y)) end function a1_exp function a2_exp(x,y) - use psb_base_mod, only : psb_spk_, sone, szero + implicit none real(psb_spk_) :: a2_exp real(psb_spk_), intent(in) :: x,y - a2=sone*epsilon*exp(-(x+y)) + a2_exp=sone*epsilon*exp(-(x+y)) end function a2_exp function g_exp(x,y) - use psb_base_mod, only : psb_spk_, sone, szero + implicit none real(psb_spk_) :: g_exp real(psb_spk_), intent(in) :: x,y g_exp = szero diff --git a/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 b/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 index ed420eda..0ce83989 100644 --- a/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 @@ -35,7 +35,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! module amg_s_pde3d_base_mod - use psb_base_mod, only : psb_spk_, sone + use psb_base_mod, only : psb_spk_, sone, szero real(psb_spk_), save, private :: epsilon=sone/80 contains subroutine pde_set_parm(dat) @@ -46,49 +46,49 @@ contains ! functions parametrizing the differential equation ! function b1(x,y,z) - use psb_base_mod, only : psb_spk_, sone + implicit none real(psb_spk_) :: b1 real(psb_spk_), intent(in) :: x,y,z b1=sone/sqrt(3.0_psb_spk_) end function b1 function b2(x,y,z) - use psb_base_mod, only : psb_spk_, sone + implicit none real(psb_spk_) :: b2 real(psb_spk_), intent(in) :: x,y,z b2=sone/sqrt(3.0_psb_spk_) end function b2 function b3(x,y,z) - use psb_base_mod, only : psb_spk_, sone + implicit none real(psb_spk_) :: b3 real(psb_spk_), intent(in) :: x,y,z b3=sone/sqrt(3.0_psb_spk_) end function b3 function c(x,y,z) - use psb_base_mod, only : psb_spk_, szero, sone + implicit none real(psb_spk_) :: c real(psb_spk_), intent(in) :: x,y,z c=szero end function c function a1(x,y,z) - use psb_base_mod, only : psb_spk_ + implicit none real(psb_spk_) :: a1 real(psb_spk_), intent(in) :: x,y,z a1=epsilon end function a1 function a2(x,y,z) - use psb_base_mod, only : psb_spk_ + implicit none real(psb_spk_) :: a2 real(psb_spk_), intent(in) :: x,y,z a2=epsilon end function a2 function a3(x,y,z) - use psb_base_mod, only : psb_spk_ + implicit none real(psb_spk_) :: a3 real(psb_spk_), intent(in) :: x,y,z a3=epsilon end function a3 function g(x,y,z) - use psb_base_mod, only : psb_spk_, sone, szero + implicit none real(psb_spk_) :: g real(psb_spk_), intent(in) :: x,y,z g = szero diff --git a/samples/advanced/pdegen/amg_s_pde3d_exp_mod.f90 b/samples/advanced/pdegen/amg_s_pde3d_exp_mod.f90 index 242ed429..8ec96d00 100644 --- a/samples/advanced/pdegen/amg_s_pde3d_exp_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde3d_exp_mod.f90 @@ -35,7 +35,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! module amg_s_pde3d_exp_mod - use psb_base_mod, only : psb_spk_, sone + use psb_base_mod, only : psb_spk_, sone, szero real(psb_spk_), save, private :: epsilon=sone/160 contains subroutine pde_set_parm(dat) @@ -46,49 +46,49 @@ contains ! functions parametrizing the differential equation ! function b1_exp(x,y,z) - use psb_base_mod, only : psb_spk_, szero + implicit none real(psb_spk_) :: b1_exp real(psb_spk_), intent(in) :: x,y,z b1_exp=szero/sqrt(3.0_psb_spk_) end function b1_exp function b2_exp(x,y,z) - use psb_base_mod, only : psb_spk_, szero + implicit none real(psb_spk_) :: b2_exp real(psb_spk_), intent(in) :: x,y,z b2_exp=szero/sqrt(3.0_psb_spk_) end function b2_exp function b3_exp(x,y,z) - use psb_base_mod, only : psb_spk_, szero + implicit none real(psb_spk_) :: b3_exp real(psb_spk_), intent(in) :: x,y,z b3_exp=szero/sqrt(3.0_psb_spk_) end function b3_exp function c_exp(x,y,z) - use psb_base_mod, only : psb_spk_, szero + implicit none real(psb_spk_) :: c_exp real(psb_spk_), intent(in) :: x,y,z c_exp=szero end function c_exp function a1_exp(x,y,z) - use psb_base_mod, only : psb_spk_ + implicit none real(psb_spk_) :: a1_exp real(psb_spk_), intent(in) :: x,y,z a1_exp=epsilon*exp(-(x+y+z)) end function a1_exp function a2_exp(x,y,z) - use psb_base_mod, only : psb_spk_ + implicit none real(psb_spk_) :: a2_exp real(psb_spk_), intent(in) :: x,y,z a2_exp=epsilon*exp(-(x+y+z)) end function a2_exp function a3_exp(x,y,z) - use psb_base_mod, only : psb_spk_ + implicit none real(psb_spk_) :: a3_exp real(psb_spk_), intent(in) :: x,y,z a3_exp=epsilon*exp(-(x+y+z)) end function a3_exp function g_exp(x,y,z) - use psb_base_mod, only : psb_spk_, sone, szero + implicit none real(psb_spk_) :: g_exp real(psb_spk_), intent(in) :: x,y,z g_exp = szero diff --git a/samples/advanced/pdegen/amg_s_pde3d_gauss_mod.f90 b/samples/advanced/pdegen/amg_s_pde3d_gauss_mod.f90 index 20d4017d..fa6362e0 100644 --- a/samples/advanced/pdegen/amg_s_pde3d_gauss_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde3d_gauss_mod.f90 @@ -35,7 +35,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! module amg_s_pde3d_gauss_mod - use psb_base_mod, only : psb_spk_, sone + use psb_base_mod, only : psb_spk_, sone, szero real(psb_spk_), save, private :: epsilon=sone/80 contains subroutine pde_set_parm(dat) @@ -46,49 +46,49 @@ contains ! functions parametrizing the differential equation ! function b1_gauss(x,y,z) - use psb_base_mod, only : psb_spk_, sone + implicit none real(psb_spk_) :: b1_gauss real(psb_spk_), intent(in) :: x,y,z b1_gauss=sone/sqrt(3.0_psb_spk_)-2*x*exp(-(x**2+y**2+z**2)) end function b1_gauss function b2_gauss(x,y,z) - use psb_base_mod, only : psb_spk_, sone + implicit none real(psb_spk_) :: b2_gauss real(psb_spk_), intent(in) :: x,y,z b2_gauss=sone/sqrt(3.0_psb_spk_)-2*y*exp(-(x**2+y**2+z**2)) end function b2_gauss function b3_gauss(x,y,z) - use psb_base_mod, only : psb_spk_, sone + implicit none real(psb_spk_) :: b3_gauss real(psb_spk_), intent(in) :: x,y,z b3_gauss=sone/sqrt(3.0_psb_spk_)-2*z*exp(-(x**2+y**2+z**2)) end function b3_gauss function c_gauss(x,y,z) - use psb_base_mod, only : psb_spk_, szero + implicit none real(psb_spk_) :: c_gauss real(psb_spk_), intent(in) :: x,y,z - c=szero + c_gauss=szero end function c_gauss function a1_gauss(x,y,z) - use psb_base_mod, only : psb_spk_ + implicit none real(psb_spk_) :: a1_gauss real(psb_spk_), intent(in) :: x,y,z a1_gauss=epsilon*exp(-(x**2+y**2+z**2)) end function a1_gauss function a2_gauss(x,y,z) - use psb_base_mod, only : psb_spk_ + implicit none real(psb_spk_) :: a2_gauss real(psb_spk_), intent(in) :: x,y,z a2_gauss=epsilon*exp(-(x**2+y**2+z**2)) end function a2_gauss function a3_gauss(x,y,z) - use psb_base_mod, only : psb_spk_ + implicit none real(psb_spk_) :: a3_gauss real(psb_spk_), intent(in) :: x,y,z a3_gauss=epsilon*exp(-(x**2+y**2+z**2)) end function a3_gauss function g_gauss(x,y,z) - use psb_base_mod, only : psb_spk_, sone, szero + implicit none real(psb_spk_) :: g_gauss real(psb_spk_), intent(in) :: x,y,z g_gauss = szero From ec9fcb1bcc22754f901cdca5c9ec871af0602dc2 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 17 Nov 2023 13:14:06 +0100 Subject: [PATCH 03/51] Adjustments for POLYNOMIAL smoothers. --- amgprec/Makefile | 4 +- amgprec/amg_base_prec_type.F90 | 12 +++ amgprec/amg_d_poly_coeff_mod.f90 | 4 +- amgprec/amg_d_poly_smoother.f90 | 5 +- amgprec/amg_d_prec_mod.f90 | 1 - amgprec/impl/amg_dcprecset.F90 | 8 +- amgprec/impl/amg_dprecinit.F90 | 2 +- .../impl/level/amg_d_base_onelev_csetc.F90 | 9 +-- .../impl/level/amg_d_base_onelev_cseti.F90 | 6 -- .../amg_d_jac_smoother_apply_vect.f90 | 13 ++- .../smoother/amg_d_jac_smoother_clone.f90 | 1 - .../amg_d_poly_smoother_apply_vect.f90 | 79 +++++++++++++++---- .../impl/smoother/amg_d_poly_smoother_bld.f90 | 49 +++++++++++- .../smoother/amg_d_poly_smoother_csetc.f90 | 6 +- .../smoother/amg_d_poly_smoother_cseti.f90 | 10 ++- .../smoother/amg_d_poly_smoother_descr.f90 | 8 ++ amgprec/impl/solver/amg_c_ilu_solver_bld.f90 | 6 +- amgprec/impl/solver/amg_d_ilu_solver_bld.f90 | 6 +- amgprec/impl/solver/amg_s_ilu_solver_bld.f90 | 6 +- amgprec/impl/solver/amg_z_ilu_solver_bld.f90 | 6 +- samples/advanced/pdegen/amg_d_pde3d.F90 | 26 +++--- samples/advanced/pdegen/runs/amg_pde3d.inp | 14 ++-- 22 files changed, 200 insertions(+), 81 deletions(-) diff --git a/amgprec/Makefile b/amgprec/Makefile index 0442f5ac..79842c27 100644 --- a/amgprec/Makefile +++ b/amgprec/Makefile @@ -9,7 +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_beta_coeff_mod.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 \ @@ -165,7 +165,7 @@ 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_beta_coeff_mod.o +amg_d_poly_smoother.o: amg_d_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 63f446c2..0bd44079 100644 --- a/amgprec/amg_base_prec_type.F90 +++ b/amgprec/amg_base_prec_type.F90 @@ -321,6 +321,12 @@ module amg_base_prec_type 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 + ! ! Legal values for entry: amg_prec_status_ ! integer(psb_ipk_), parameter :: amg_prec_built_ = 98765 @@ -560,6 +566,12 @@ contains 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('A_NORMI') val = amg_max_norm_ case('USER_CHOICE') diff --git a/amgprec/amg_d_poly_coeff_mod.f90 b/amgprec/amg_d_poly_coeff_mod.f90 index 1bbeb876..8a7d8ad3 100644 --- a/amgprec/amg_d_poly_coeff_mod.f90 +++ b/amgprec/amg_d_poly_coeff_mod.f90 @@ -49,7 +49,7 @@ ! main diagonal block), so that it becomes possible to implement ! a pure Jacobi or L1-Jacobi global solver. ! -module amg_d_beta_coeff_mod +module amg_d_poly_coeff_mod use psb_base_mod real(psb_dpk_), parameter :: amg_d_beta_vect(900) = [ & @@ -513,4 +513,4 @@ module amg_d_beta_coeff_mod real(psb_dpk_), parameter :: amg_d_beta_mat(30,30)=reshape(amg_d_beta_vect,[30,30]) -end module amg_d_beta_coeff_mod +end module amg_d_poly_coeff_mod diff --git a/amgprec/amg_d_poly_smoother.f90 b/amgprec/amg_d_poly_smoother.f90 index aa1dd5d1..7e444550 100644 --- a/amgprec/amg_d_poly_smoother.f90 +++ b/amgprec/amg_d_poly_smoother.f90 @@ -51,14 +51,14 @@ ! module amg_d_poly_smoother use amg_d_base_smoother_mod - use amg_d_beta_coeff_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 + integer(psb_ipk_) :: pdegree, variant type(psb_dspmat_type), pointer :: pa => null() real(psb_dpk_), allocatable :: poly_beta(:) real(psb_dpk_) :: rho_ba @@ -319,6 +319,7 @@ contains ! sm%pdegree = 1 sm%rho_ba = dzero + sm%variant = amg_poly_lottes_ if (allocated(sm%sv)) then call sm%sv%default() diff --git a/amgprec/amg_d_prec_mod.f90 b/amgprec/amg_d_prec_mod.f90 index f86133d8..96e2f974 100644 --- a/amgprec/amg_d_prec_mod.f90 +++ b/amgprec/amg_d_prec_mod.f90 @@ -47,7 +47,6 @@ module amg_d_prec_mod use amg_d_prec_type use amg_d_jac_smoother use amg_d_as_smoother - use amg_d_poly_smoother use amg_d_id_solver use amg_d_diag_solver use amg_d_l1_diag_solver diff --git a/amgprec/impl/amg_dcprecset.F90 b/amgprec/impl/amg_dcprecset.F90 index c46f5224..83589e17 100644 --- a/amgprec/impl/amg_dcprecset.F90 +++ b/amgprec/impl/amg_dcprecset.F90 @@ -81,7 +81,6 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) use amg_d_prec_mod, amg_protect_name => amg_dcprecseti use amg_d_jac_smoother use amg_d_as_smoother - use amg_d_poly_smoother use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_ilu_solver @@ -126,7 +125,7 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) info = 3111 write(psb_err_unit,*) name,& & ': Error: uninitialized preconditioner,',& - & ' should call amg_PRECINIT' + &' should call amg_PRECINIT' return endif @@ -313,7 +312,6 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) use amg_d_prec_mod, amg_protect_name => amg_dcprecsetc use amg_d_jac_smoother use amg_d_as_smoother - use amg_d_poly_smoother use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_ilu_solver @@ -404,10 +402,6 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) do il=ilev_, ilmax_ call p%precv(il)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos) end do - case ('POLY') - do il=ilev_, ilmax_ - call p%precv(il)%set('SMOOTHER_TYPE',amg_poly_,info,pos=pos) - end do case ('L1-BJAC') do il=ilev_, ilmax_ call p%precv(il)%set('SMOOTHER_TYPE',amg_l1_bjac_,info,pos=pos) diff --git a/amgprec/impl/amg_dprecinit.F90 b/amgprec/impl/amg_dprecinit.F90 index 491d8eca..8f3c0cb6 100644 --- a/amgprec/impl/amg_dprecinit.F90 +++ b/amgprec/impl/amg_dprecinit.F90 @@ -163,7 +163,7 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info) 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_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) + 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') diff --git a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 index c8a8941d..d4d37262 100644 --- a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 @@ -207,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 195fbed7..c60ff895 100644 --- a/amgprec/impl/level/amg_d_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_cseti.F90 @@ -45,7 +45,6 @@ subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx) use amg_d_parmatch_aggregator_mod use amg_d_jac_smoother use amg_d_as_smoother - use amg_d_poly_smoother use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_ilu_solver @@ -80,7 +79,6 @@ subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx) type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold - type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold @@ -143,10 +141,6 @@ subroutine amg_d_base_onelev_cseti(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 (amg_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 (amg_fbgs_) 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') 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..1c206c27 100644 --- a/amgprec/impl/smoother/amg_d_jac_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_jac_smoother_apply_vect.f90 @@ -109,7 +109,7 @@ subroutine amg_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if endif - if(sm%checkres) then + if(.true..or.sm%checkres) then call psb_geall(r,desc_data,info) call psb_geasb(r,desc_data,info) resdenum = psb_genrm2(x,desc_data,info) @@ -159,7 +159,10 @@ subroutine amg_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & a_err='wrong init to smoother_apply') goto 9999 end select - +!!$ 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) +!!$ write(0,*) 'Jacobi smoother ',1,res do i=1, sweeps-1 ! ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), @@ -173,9 +176,13 @@ subroutine amg_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit +!!$ 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) +!!$ write(0,*) 'Jacobi smoother ',i+1,res 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_jac_smoother_clone.f90 b/amgprec/impl/smoother/amg_d_jac_smoother_clone.f90 index 1a084f87..21b6da06 100644 --- a/amgprec/impl/smoother/amg_d_jac_smoother_clone.f90 +++ b/amgprec/impl/smoother/amg_d_jac_smoother_clone.f90 @@ -72,7 +72,6 @@ subroutine amg_d_jac_smoother_clone(sm,smout,info) smo%checkiter = sm%checkiter smo%printiter = sm%printiter smo%tol = sm%tol - smo%pa => sm%pa call sm%nd%clone(smo%nd,info) if ((info==psb_success_).and.(allocated(sm%sv))) then allocate(smout%sv,mold=sm%sv,stat=info) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index 2fc3115c..044c4fb5 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -129,15 +129,64 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call ty%zero() call tz%zero() - do i=1, sm%pdegree - call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Y') - cz = (2*i*done-3)/(2*i*done+done) - cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - call psb_geaxpby(sm%poly_beta(i),tz,done,tx,desc_data,info) - call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) - end do + select case(sm%variant) + case(amg_poly_lottes_) + ! b == x + ! x == tx + ! + do i=1, sm%pdegree + ! B r_{k-1} + call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + cz = (2*i*done-3)/(2*i*done+done) + cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(done,tz,done,tx,desc_data,info) + if (.false.) then + call psb_geaxpby(done,x,dzero,r,desc_data,info) + call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) + else + call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) + end if +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother ',i,res + ! x_k = x_{k-1} + z_k + end do + case(amg_poly_lottes_beta_) + + ! b == x + ! x == tx + ! + do i=1, sm%pdegree + ! B r_{k-1} + call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + cz = (2*i*done-3)/(2*i*done+done) + cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(sm%poly_beta(i),tz,done,tx,desc_data,info) + if (.false.) then + call psb_geaxpby(done,x,dzero,r,desc_data,info) + call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) + else + call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) + end if +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother ',i,res + ! x_k = x_{k-1} + z_k + end do + + + 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 @@ -339,19 +388,19 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& !!$ !!$ endif !!$ - if (.not.(4*n_col <= size(work))) then - deallocate(aux) - endif + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif !!$ if(sm%checkres) then !!$ call psb_gefree(r,desc_data,info) !!$ end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return - end subroutine amg_d_poly_smoother_apply_vect +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 index be83a0ae..2858f9ba 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -39,7 +39,8 @@ 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_beta_coeff_mod + 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 @@ -55,6 +56,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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 @@ -83,15 +85,54 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if 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 (sm%rho_ba <= dzero) then - sm%rho_ba = psb_dspnrm1(a,desc_a,info) + + if (.true.) 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 + block + type(psb_d_vect_type) :: tq, tz,wv(2) + real(psb_dpk_) :: qnrm, 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(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,tz,desc_a,info) ! z_1 = A q_0 + do i=1,10 + call sm%sv%apply_v(done,tz,dzero,tq,desc_a,'NoTrans',work,wv,info) ! q_k = M^{-1} q_k + qnrm = psb_genrmi(tq,desc_a,info) ! qnrm = |q_k|_inf + call tq%scal((done/qnrm)) ! q_k = q_k/qnrm + call psb_spmm(done,a,tq,dzero,tz,desc_a,info) ! z_{k=1} = A q_k + lambda = psb_gedot(tq,tz,desc_a,info) ! lambda = q_k^T z_{k+1} = q_k^T A q_k + write(0,*) 'BLD: lambda estimate ',i,lambda + end do + sm%rho_ba = lambda + end block end if if (debug_level >= psb_debug_outer_) & diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 index 3c1fef00..0cc786ed 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 @@ -53,8 +53,10 @@ subroutine amg_d_poly_smoother_csetc(sm,what,val,info,idx) call psb_erractionsave(err_act) select case(psb_toupper(trim(what))) - case default - call sm%amg_d_base_smoother_type%set(what,val,info,idx=idx) + case('POLY-VARIANT') + 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 index 8bc48724..d3db3891 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 @@ -54,8 +54,16 @@ subroutine amg_d_poly_smoother_cseti(sm,what,val,info,idx) call psb_erractionsave(err_act) select case(psb_toupper(what)) - case('SMOOTHER_DEGREE') + 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_' + sm%variant = amg_poly_lottes_ + end select case default call sm%amg_d_base_smoother_type%set(what,val,info,idx=idx) end select diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 index d17c5aa5..51c198b1 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 @@ -78,6 +78,14 @@ subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) end if write(iout_,*) trim(prefix_), ' Polynomial smoother ' + select case(sm%variant) + case(amg_poly_lottes_) + write(iout_,*) trim(prefix_), ' variant: ','POLY_LOTTES' + case(amg_poly_lottes_beta_) + write(iout_,*) trim(prefix_), ' variant: ','POLY_LOTTES_BETA' + case default + write(iout_,*) trim(prefix_), ' variant: ','UNKNOWN???' + end select 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) diff --git a/amgprec/impl/solver/amg_c_ilu_solver_bld.f90 b/amgprec/impl/solver/amg_c_ilu_solver_bld.f90 index 9f6109db..a348fcea 100644 --- a/amgprec/impl/solver/amg_c_ilu_solver_bld.f90 +++ b/amgprec/impl/solver/amg_c_ilu_solver_bld.f90 @@ -99,11 +99,11 @@ subroutine amg_c_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) select case(sv%fact_type) case (amg_ilu_n_) - psb_fctype = amg_ilu_n_ + psb_fctype = psb_ilu_n_ case (amg_milu_n_) - psb_fctype = amg_milu_n_ + psb_fctype = psb_milu_n_ case (amg_ilu_t_) - psb_fctype = 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_ diff --git a/amgprec/impl/solver/amg_d_ilu_solver_bld.f90 b/amgprec/impl/solver/amg_d_ilu_solver_bld.f90 index c4ab246a..7a49e47e 100644 --- a/amgprec/impl/solver/amg_d_ilu_solver_bld.f90 +++ b/amgprec/impl/solver/amg_d_ilu_solver_bld.f90 @@ -99,11 +99,11 @@ subroutine amg_d_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) select case(sv%fact_type) case (amg_ilu_n_) - psb_fctype = amg_ilu_n_ + psb_fctype = psb_ilu_n_ case (amg_milu_n_) - psb_fctype = amg_milu_n_ + psb_fctype = psb_milu_n_ case (amg_ilu_t_) - psb_fctype = 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_ diff --git a/amgprec/impl/solver/amg_s_ilu_solver_bld.f90 b/amgprec/impl/solver/amg_s_ilu_solver_bld.f90 index 8cfadb3b..6c36bec2 100644 --- a/amgprec/impl/solver/amg_s_ilu_solver_bld.f90 +++ b/amgprec/impl/solver/amg_s_ilu_solver_bld.f90 @@ -99,11 +99,11 @@ subroutine amg_s_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) select case(sv%fact_type) case (amg_ilu_n_) - psb_fctype = amg_ilu_n_ + psb_fctype = psb_ilu_n_ case (amg_milu_n_) - psb_fctype = amg_milu_n_ + psb_fctype = psb_milu_n_ case (amg_ilu_t_) - psb_fctype = 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_ diff --git a/amgprec/impl/solver/amg_z_ilu_solver_bld.f90 b/amgprec/impl/solver/amg_z_ilu_solver_bld.f90 index 3afa82f7..36c91ad8 100644 --- a/amgprec/impl/solver/amg_z_ilu_solver_bld.f90 +++ b/amgprec/impl/solver/amg_z_ilu_solver_bld.f90 @@ -99,11 +99,11 @@ subroutine amg_z_ilu_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) select case(sv%fact_type) case (amg_ilu_n_) - psb_fctype = amg_ilu_n_ + psb_fctype = psb_ilu_n_ case (amg_milu_n_) - psb_fctype = amg_milu_n_ + psb_fctype = psb_milu_n_ case (amg_ilu_t_) - psb_fctype = 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_ diff --git a/samples/advanced/pdegen/amg_d_pde3d.F90 b/samples/advanced/pdegen/amg_d_pde3d.F90 index 410b6e01..927fb943 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.F90 +++ b/samples/advanced/pdegen/amg_d_pde3d.F90 @@ -145,6 +145,7 @@ program amg_d_pde3d character(len=16) :: 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=16) :: pvariant ! Polynomial smoother variant integer(psb_ipk_) :: novr ! number of overlap layers character(len=16) :: restr ! restriction over application of AS character(len=16) :: prol ! prolongation over application of AS @@ -154,12 +155,13 @@ program amg_d_pde3d character(len=16) :: variant ! AINV variant: LLK, etc integer(psb_ipk_) :: fill ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill ! Inverse fill-in for INVK - real(psb_dpk_) :: thr ! threshold for ILUT factorization + real(psb_dpk_) :: thr ! threshold for ILUT factorization ! AMG post-smoother; ignored by 1-lev preconditioner character(len=16) :: smther2 ! post-smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps2 ! post-smoother sweeps integer(psb_ipk_) :: degree2 ! degree for polynomial smoother + character(len=16) :: pvariant2 ! Polynomial smoother variant integer(psb_ipk_) :: novr2 ! number of overlap layers character(len=16) :: restr2 ! restriction over application of AS character(len=16) :: prol2 ! prolongation over application of AS @@ -169,7 +171,7 @@ program amg_d_pde3d character(len=16) :: variant2 ! AINV variant: LLK, etc integer(psb_ipk_) :: fill2 ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill2 ! Inverse fill-in for INVK - real(psb_dpk_) :: thr2 ! threshold for ILUT factorization + real(psb_dpk_) :: thr2 ! threshold for ILUT factorization ! coarsest-level solver character(len=16) :: cmat ! coarsest matrix layout: REPL, DIST @@ -291,7 +293,8 @@ program amg_d_pde3d 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('smoother_degree', p_choice%degree, info) + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%variant, 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) @@ -339,7 +342,8 @@ 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('smoother_degree', p_choice%degree, info) + call prec%set('poly_degree', p_choice%degree, info) + call prec%set('poly_variant', p_choice%variant, info) select case (psb_toupper(p_choice%smther)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') @@ -370,7 +374,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('smoother_degree', p_choice%degree2, info,pos='post') + call prec%set('poly_degree', p_choice%degree2, info,pos='post') + call prec%set('poly_variant', p_choice%variant2, info,pos='post') select case (psb_toupper(p_choice%smther2)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -407,7 +412,6 @@ program amg_d_pde3d call prec%set('coarse_sweeps', p_choice%cjswp, info) end select -!!$ call prec%descr(info,iout=psb_out_unit) ! build the preconditioner call psb_barrier(ctxt) @@ -587,7 +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%degree,inp_unit) ! Degree of Polynomial smoother + call read_data(prec%variant,inp_unit) ! variant for Polynomial 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 @@ -600,12 +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%degree2,inp_unit) ! Degree of Polynomial smoother + call read_data(prec%variant2,inp_unit) ! Polynomial smoother variant 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 @@ -672,6 +678,7 @@ contains call psb_bcast(ctxt,prec%smther) call psb_bcast(ctxt,prec%jsweeps) call psb_bcast(ctxt,prec%degree) + call psb_bcast(ctxt,prec%variant) call psb_bcast(ctxt,prec%novr) call psb_bcast(ctxt,prec%restr) call psb_bcast(ctxt,prec%prol) @@ -685,6 +692,7 @@ contains call psb_bcast(ctxt,prec%smther2) call psb_bcast(ctxt,prec%jsweeps2) call psb_bcast(ctxt,prec%degree2) + call psb_bcast(ctxt,prec%variant2) 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_pde3d.inp b/samples/advanced/pdegen/runs/amg_pde3d.inp index ac39c4af..96b1b592 100644 --- a/samples/advanced/pdegen/runs/amg_pde3d.inp +++ b/samples/advanced/pdegen/runs/amg_pde3d.inp @@ -4,16 +4,17 @@ CSR ! Storage format CSR COO JAD CONST ! PDECOEFF: CONST, EXP, GAUSS Coefficients of the PDE BICGSTAB ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS FCG GCR RGMRES 2 ! ISTOPC -00500 ! ITMAX +00050 ! ITMAX 1 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS %%%%%%%%%%% Main preconditioner choices %%%%%%%%%%%%%%%% ML-VBM-VCYCLE-FBGS-D-BJAC ! Longer descriptive name for preconditioner (up to 20 chars) -BJAC ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML +ML ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML %%%%%%%%%%% 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. For 1-level, repeats previous. +4 ! Number of sweeps for smoother +4 ! degree for polynomial smoother 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG @@ -24,8 +25,9 @@ LLK ! AINV variant 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 +NONE ! Second (post) smoother, ignored if NONE +4 ! Number of sweeps for (post) smoother +4 ! degree for polynomial smoother 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG From 14cd4cde765e4b3fcf7abbbb6f5eb3f86187c893 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 17 Nov 2023 13:16:41 +0100 Subject: [PATCH 04/51] Fix inpout file. --- samples/advanced/pdegen/runs/amg_pde3d.inp | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/samples/advanced/pdegen/runs/amg_pde3d.inp b/samples/advanced/pdegen/runs/amg_pde3d.inp index 96b1b592..4a0e605c 100644 --- a/samples/advanced/pdegen/runs/amg_pde3d.inp +++ b/samples/advanced/pdegen/runs/amg_pde3d.inp @@ -1,6 +1,6 @@ %%%%%%%%%%% General arguments % Lines starting with % are ignored. CSR ! Storage format CSR COO JAD -0040 ! IDIM; domain size. Linear system size is IDIM**3 +0050 ! IDIM; domain size. Linear system size is IDIM**3 CONST ! PDECOEFF: CONST, EXP, GAUSS Coefficients of the PDE BICGSTAB ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS FCG GCR RGMRES 2 ! ISTOPC @@ -13,26 +13,28 @@ ML-VBM-VCYCLE-FBGS-D-BJAC ! Longer descriptive name for preconditioner (up ML ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML %%%%%%%%%%% First smoother (for all levels but coarsest) %%%%%%%%%%%%%%%% FBGS ! Smoother type JACOBI FBGS GS BWGS BJAC AS. For 1-level, repeats previous. -4 ! Number of sweeps for smoother -4 ! degree for polynomial smoother +1 ! Number of sweeps for 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 -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 -4 ! Number of sweeps for (post) smoother -4 ! degree for polynomial smoother +FBGS ! Second (post) smoother, ignored if NONE +1 ! 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 From bb262275a19b4350f2f5e3a74863b4ddffe00976 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 17 Nov 2023 14:45:18 +0100 Subject: [PATCH 05/51] Temporary checkpoint, working version, to be investigated further. --- amgprec/amg_base_prec_type.F90 | 6 +- .../impl/smoother/amg_d_poly_smoother_bld.f90 | 27 ++++---- .../smoother/amg_d_poly_smoother_csetc.f90 | 2 +- .../smoother/amg_d_poly_smoother_cseti.f90 | 2 +- .../smoother/amg_d_poly_smoother_descr.f90 | 10 +-- samples/advanced/pdegen/amg_d_pde3d.F90 | 63 ++++++++++--------- samples/advanced/pdegen/runs/amg_pde3d.inp | 10 +-- 7 files changed, 63 insertions(+), 57 deletions(-) diff --git a/amgprec/amg_base_prec_type.F90 b/amgprec/amg_base_prec_type.F90 index 0bd44079..59b1acce 100644 --- a/amgprec/amg_base_prec_type.F90 +++ b/amgprec/amg_base_prec_type.F90 @@ -464,12 +464,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') diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index 2858f9ba..b307fef5 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -98,7 +98,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if - if (.true.) then + if (.false.) then select type(ssv => sm%sv) class is(amg_d_l1_diag_solver_type) da = a%arwsum(info) @@ -110,28 +110,31 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) end select else block - type(psb_d_vect_type) :: tq, tz,wv(2) - real(psb_dpk_) :: qnrm, lambda + 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,tz,desc_a,info) ! z_1 = A q_0 - do i=1,10 - call sm%sv%apply_v(done,tz,dzero,tq,desc_a,'NoTrans',work,wv,info) ! q_k = M^{-1} q_k - qnrm = psb_genrmi(tq,desc_a,info) ! qnrm = |q_k|_inf - call tq%scal((done/qnrm)) ! q_k = q_k/qnrm - call psb_spmm(done,a,tq,dzero,tz,desc_a,info) ! z_{k=1} = A q_k - lambda = psb_gedot(tq,tz,desc_a,info) ! lambda = q_k^T z_{k+1} = q_k^T A q_k - write(0,*) 'BLD: lambda estimate ',i,lambda + 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,20 + 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 + sm%rho_ba = done end block end if diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 index 0cc786ed..0daa387b 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 @@ -53,7 +53,7 @@ subroutine amg_d_poly_smoother_csetc(sm,what,val,info,idx) call psb_erractionsave(err_act) select case(psb_toupper(trim(what))) - case('POLY-VARIANT') + case('POLY_VARIANT') 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) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 index d3db3891..0b116deb 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 @@ -61,7 +61,7 @@ subroutine amg_d_poly_smoother_cseti(sm,what,val,info,idx) 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_' + write(0,*) 'Invalid choice for POLY_VARIANT, defaulting to amg_poly_lottes_',val sm%variant = amg_poly_lottes_ end select case default diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 index 51c198b1..0607064d 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 @@ -80,15 +80,17 @@ subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) 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_), ' 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 default write(iout_,*) trim(prefix_), ' variant: ','UNKNOWN???' end select - 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) if (allocated(sm%sv)) then write(iout_,*) trim(prefix_), ' Local solver details:' call sm%sv%descr(info,iout_,coarse=coarse,prefix=prefix) diff --git a/samples/advanced/pdegen/amg_d_pde3d.F90 b/samples/advanced/pdegen/amg_d_pde3d.F90 index 927fb943..11494e64 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.F90 +++ b/samples/advanced/pdegen/amg_d_pde3d.F90 @@ -80,7 +80,7 @@ program amg_d_pde3d implicit none ! input parameters - character(len=20) :: kmethd, ptype + character(len=24) :: kmethd, ptype character(len=5) :: afmt, pdecoeff integer(psb_ipk_) :: idim integer(psb_epk_) :: system_size @@ -120,21 +120,21 @@ program amg_d_pde3d ! preconditioner type character(len=40) :: descr ! verbose description of the prec - character(len=10) :: ptype ! preconditioner type + character(len=24) :: ptype ! preconditioner type integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level, ! AMG cycles for ML ! general AMG data - character(len=16) :: mlcycle ! AMG cycle type + character(len=24) :: mlcycle ! AMG cycle type integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner ! AMG aggregation - character(len=16) :: aggr_prol ! aggregation type: SMOOTHED, NONSMOOTHED - character(len=16) :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC - character(len=16) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP + character(len=24) :: aggr_prol ! aggregation type: SMOOTHED, NONSMOOTHED + character(len=24) :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC + character(len=24) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP integer(psb_ipk_) :: aggr_size ! Requested size of the aggregates for MATCHBOXP - character(len=16) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE - character(len=16) :: aggr_filter ! filtering: FILTER, NO_FILTER + character(len=24) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE + character(len=24) :: 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 @@ -142,43 +142,43 @@ program amg_d_pde3d integer(psb_ipk_) :: csizepp ! minimum size of coarsest matrix per process ! AMG smoother or pre-smoother; also 1-lev preconditioner - character(len=16) :: smther ! (pre-)smoother type: BJAC, AS + character(len=24) :: 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=16) :: pvariant ! Polynomial smoother variant + character(len=24) :: pvariant ! Polynomial smoother variant integer(psb_ipk_) :: novr ! number of overlap layers - character(len=16) :: restr ! restriction over application of AS - character(len=16) :: prol ! prolongation over application of AS - character(len=16) :: solve ! local subsolver type: ILU, MILU, ILUT, + character(len=24) :: restr ! restriction over application of AS + character(len=24) :: prol ! prolongation over application of AS + character(len=24) :: solve ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps ! inner solver sweeps - character(len=16) :: variant ! AINV variant: LLK, etc + character(len=24) :: variant ! AINV variant: LLK, etc integer(psb_ipk_) :: fill ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill ! Inverse fill-in for INVK real(psb_dpk_) :: thr ! threshold for ILUT factorization ! AMG post-smoother; ignored by 1-lev preconditioner - character(len=16) :: smther2 ! post-smoother type: BJAC, AS + character(len=24) :: smther2 ! post-smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps2 ! post-smoother sweeps integer(psb_ipk_) :: degree2 ! degree for polynomial smoother - character(len=16) :: pvariant2 ! Polynomial smoother variant + character(len=24) :: pvariant2 ! Polynomial smoother variant integer(psb_ipk_) :: novr2 ! number of overlap layers - character(len=16) :: restr2 ! restriction over application of AS - character(len=16) :: prol2 ! prolongation over application of AS - character(len=16) :: solve2 ! local subsolver type: ILU, MILU, ILUT, + character(len=24) :: restr2 ! restriction over application of AS + character(len=24) :: prol2 ! prolongation over application of AS + character(len=24) :: solve2 ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps2 ! inner solver sweeps - character(len=16) :: variant2 ! AINV variant: LLK, etc + character(len=24) :: variant2 ! AINV variant: LLK, etc integer(psb_ipk_) :: fill2 ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill2 ! Inverse fill-in for INVK real(psb_dpk_) :: thr2 ! threshold for ILUT factorization ! coarsest-level solver - character(len=16) :: cmat ! coarsest matrix layout: REPL, DIST - character(len=16) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. + character(len=24) :: cmat ! coarsest matrix layout: REPL, DIST + character(len=24) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. ! mat.); UMF, MUMPS, SLU, ILU, ILUT, MILU ! (repl. mat.) - character(len=16) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT, + character(len=24) :: 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 @@ -200,7 +200,7 @@ program amg_d_pde3d ! other variables integer(psb_ipk_) :: info, i, k - character(len=20) :: name,ch_err + character(len=24) :: name,ch_err type(psb_d_csr_sparse_mat) :: amold info=psb_success_ @@ -294,7 +294,7 @@ program amg_d_pde3d 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%variant, 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) @@ -343,7 +343,8 @@ 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%variant, info) + write(0,*) 'pvariant :',p_choice%pvariant + 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') @@ -375,7 +376,7 @@ program amg_d_pde3d 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%variant2, 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 @@ -592,7 +593,7 @@ contains 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) ! Degree of Polynomial smoother - call read_data(prec%variant,inp_unit) ! variant for Polynomial + call read_data(prec%pvariant,inp_unit) ! variant for Polynomial 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 @@ -606,7 +607,7 @@ contains 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) ! Degree of Polynomial smoother - call read_data(prec%variant2,inp_unit) ! Polynomial smoother variant + call read_data(prec%pvariant2,inp_unit) ! Polynomial smoother variant 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 @@ -678,7 +679,7 @@ contains call psb_bcast(ctxt,prec%smther) call psb_bcast(ctxt,prec%jsweeps) call psb_bcast(ctxt,prec%degree) - call psb_bcast(ctxt,prec%variant) + call psb_bcast(ctxt,prec%pvariant) call psb_bcast(ctxt,prec%novr) call psb_bcast(ctxt,prec%restr) call psb_bcast(ctxt,prec%prol) @@ -692,7 +693,7 @@ contains call psb_bcast(ctxt,prec%smther2) call psb_bcast(ctxt,prec%jsweeps2) call psb_bcast(ctxt,prec%degree2) - call psb_bcast(ctxt,prec%variant2) + 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_pde3d.inp b/samples/advanced/pdegen/runs/amg_pde3d.inp index 4a0e605c..95de34a6 100644 --- a/samples/advanced/pdegen/runs/amg_pde3d.inp +++ b/samples/advanced/pdegen/runs/amg_pde3d.inp @@ -1,6 +1,6 @@ %%%%%%%%%%% General arguments % Lines starting with % are ignored. CSR ! Storage format CSR COO JAD -0050 ! IDIM; domain size. Linear system size is IDIM**3 +0150 ! IDIM; domain size. Linear system size is IDIM**3 CONST ! PDECOEFF: CONST, EXP, GAUSS Coefficients of the PDE BICGSTAB ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS FCG GCR RGMRES 2 ! ISTOPC @@ -12,8 +12,8 @@ BICGSTAB ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS F 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 %%%%%%%%%%% First smoother (for all levels but coarsest) %%%%%%%%%%%%%%%% -FBGS ! Smoother type JACOBI FBGS GS BWGS BJAC AS. For 1-level, repeats previous. -1 ! Number of sweeps for smoother +L1-JACOBI ! Smoother type JACOBI FBGS GS BWGS BJAC AS. For 1-level, repeats previous. +6 ! Number of sweeps for smoother 1 ! degree for polynomial smoother POLY_LOTTES_BETA ! Polynomial variant 0 ! Number of overlap layers for AS preconditioner @@ -26,8 +26,8 @@ LLK ! AINV variant 1 ! Inverse Fill level P for INVK 1.d-4 ! Threshold T for ILU(T,P) %%%%%%%%%%% Second smoother, always ignored for non-ML %%%%%%%%%%%%%%%% -FBGS ! Second (post) smoother, ignored if NONE -1 ! Number of sweeps for (post) smoother +L1-JACOBI ! Second (post) smoother, ignored if NONE +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 From bee9d63e9c026db674ed471d27e96e4dd54ed6a5 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 17 Nov 2023 14:46:22 +0100 Subject: [PATCH 06/51] Take out debug statement --- samples/advanced/pdegen/amg_d_pde3d.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/samples/advanced/pdegen/amg_d_pde3d.F90 b/samples/advanced/pdegen/amg_d_pde3d.F90 index 11494e64..24631320 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.F90 +++ b/samples/advanced/pdegen/amg_d_pde3d.F90 @@ -343,7 +343,6 @@ 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) - write(0,*) 'pvariant :',p_choice%pvariant call prec%set('poly_variant', p_choice%pvariant, info) select case (psb_toupper(p_choice%smther)) From 6ad82037c53647c02303c062b540f44f82eda6ff Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 17 Nov 2023 14:49:20 +0100 Subject: [PATCH 07/51] Add comments in smoother fields --- samples/advanced/pdegen/runs/amg_pde3d.inp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/samples/advanced/pdegen/runs/amg_pde3d.inp b/samples/advanced/pdegen/runs/amg_pde3d.inp index 95de34a6..b91f5143 100644 --- a/samples/advanced/pdegen/runs/amg_pde3d.inp +++ b/samples/advanced/pdegen/runs/amg_pde3d.inp @@ -2,7 +2,7 @@ CSR ! Storage format CSR COO JAD 0150 ! IDIM; domain size. Linear system size is IDIM**3 CONST ! PDECOEFF: CONST, EXP, GAUSS Coefficients of the PDE -BICGSTAB ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS FCG GCR RGMRES +CG ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS FCG GCR RGMRES 2 ! ISTOPC 00050 ! ITMAX 1 ! ITRACE @@ -10,9 +10,9 @@ BICGSTAB ! 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) -ML ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML +ML ! Preconditioner type: NONE JACOBI GS FBGS BJAC AS ML POLY %%%%%%%%%%% First smoother (for all levels but coarsest) %%%%%%%%%%%%%%%% -L1-JACOBI ! Smoother type JACOBI FBGS GS BWGS BJAC AS. For 1-level, repeats previous. +L1-JACOBI ! 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 From 847ed6ae60e981a6bdeb5a98e6519c03be0bf69b Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 17 Nov 2023 14:56:51 +0100 Subject: [PATCH 08/51] Estimate rho(BA) --- amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index b307fef5..2158e3ae 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -134,7 +134,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) !write(0,*) 'BLD: lambda estimate ',i,lambda end do sm%rho_ba = lambda - sm%rho_ba = done + !sm%rho_ba = done end block end if From 79317cb392e473905d7bb363d28dfc63db848f64 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 17 Nov 2023 15:35:15 +0100 Subject: [PATCH 09/51] Additional fields for rho(BA) estimate. --- amgprec/amg_base_prec_type.F90 | 5 ++ amgprec/amg_d_poly_smoother.f90 | 13 +-- .../impl/smoother/amg_d_poly_smoother_bld.f90 | 80 ++++++++++--------- .../smoother/amg_d_poly_smoother_csetc.f90 | 2 + .../smoother/amg_d_poly_smoother_cseti.f90 | 15 ++++ .../smoother/amg_d_poly_smoother_csetr.f90 | 9 ++- samples/advanced/pdegen/runs/amg_pde3d.inp | 8 +- 7 files changed, 87 insertions(+), 45 deletions(-) diff --git a/amgprec/amg_base_prec_type.F90 b/amgprec/amg_base_prec_type.F90 index 59b1acce..5d75e274 100644 --- a/amgprec/amg_base_prec_type.F90 +++ b/amgprec/amg_base_prec_type.F90 @@ -326,6 +326,9 @@ module amg_base_prec_type 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_rho_est_power_ = 0 + ! ! Legal values for entry: amg_prec_status_ ! @@ -572,6 +575,8 @@ contains val = amg_poly_lottes_beta_ case('POLY_NEW') val = amg_poly_new_ + case('POLY_RHO_EST_POWER') + val = amg_poly_rho_est_power_ case('A_NORMI') val = amg_max_norm_ case('USER_CHOICE') diff --git a/amgprec/amg_d_poly_smoother.f90 b/amgprec/amg_d_poly_smoother.f90 index 7e444550..2d0ac1e1 100644 --- a/amgprec/amg_d_poly_smoother.f90 +++ b/amgprec/amg_d_poly_smoother.f90 @@ -59,9 +59,11 @@ module amg_d_poly_smoother ! 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_) :: rho_ba + 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 @@ -317,10 +319,11 @@ contains ! ! Default: BJAC with no residual check ! - sm%pdegree = 1 - sm%rho_ba = dzero - sm%variant = amg_poly_lottes_ - + 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index 2158e3ae..d668bac0 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -98,44 +98,50 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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 +!!$ 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 - else - 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,20 - 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 - !sm%rho_ba = done - end block end if if (debug_level >= psb_debug_outer_) & diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 index 0daa387b..e61b09e3 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 @@ -55,6 +55,8 @@ subroutine amg_d_poly_smoother_csetc(sm,what,val,info,idx) 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 index 0b116deb..916fb5e6 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 @@ -64,6 +64,21 @@ subroutine amg_d_poly_smoother_cseti(sm,what,val,info,idx) 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90 index de308a8e..f1987a7b 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_csetr.f90 @@ -54,8 +54,13 @@ subroutine amg_d_poly_smoother_csetr(sm,what,val,info,idx) call psb_erractionsave(err_act) select case(psb_toupper(what)) - case('RHO_BA') - sm%rho_ba = val + case('POLY_RHO_BA') + if ((dzero Date: Fri, 17 Nov 2023 16:01:52 +0100 Subject: [PATCH 10/51] Prepare for new variant. --- amgprec/amg_d_poly_coeff_mod.f90 | 36 +++++++++++++++++- amgprec/amg_d_poly_smoother.f90 | 1 + .../impl/smoother/amg_d_poly_smoother_bld.f90 | 38 +++++++++++++++---- 3 files changed, 65 insertions(+), 10 deletions(-) diff --git a/amgprec/amg_d_poly_coeff_mod.f90 b/amgprec/amg_d_poly_coeff_mod.f90 index 8a7d8ad3..69c56aba 100644 --- a/amgprec/amg_d_poly_coeff_mod.f90 +++ b/amgprec/amg_d_poly_coeff_mod.f90 @@ -52,7 +52,39 @@ module amg_d_poly_coeff_mod use psb_base_mod - real(psb_dpk_), parameter :: amg_d_beta_vect(900) = [ & + 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_, & @@ -511,6 +543,6 @@ module amg_d_poly_coeff_mod !!$ & 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_beta_mat(30,30)=reshape(amg_d_beta_vect,[30,30]) + 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 index 2d0ac1e1..5ba83c24 100644 --- a/amgprec/amg_d_poly_smoother.f90 +++ b/amgprec/amg_d_poly_smoother.f90 @@ -63,6 +63,7 @@ module amg_d_poly_smoother integer(psb_ipk_) :: rho_estimate_iterations=10 type(psb_dspmat_type), pointer :: pa => null() real(psb_dpk_), allocatable :: poly_beta(:) + real(psb_dpk_), allocatable :: poly_a(:) real(psb_dpk_) :: rho_ba = -done contains procedure, pass(sm) :: apply_v => 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 index d668bac0..4c587f4e 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -75,15 +75,37 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) nrow_a = a%get_nrows() nztota = a%get_nzeros() - 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_beta_mat(1:sm%pdegree,sm%pdegree) - else + 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<=6)) then + call psb_realloc(sm%pdegree,sm%poly_a,info) + sm%poly_a(1:sm%pdegree) = amg_d_poly_a_vect(1: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%degree') + & a_err='invalid sm%variant') goto 9999 - end if + end select + sm%pa => a if (.not.allocated(sm%sv)) then info = psb_err_internal_error_ @@ -97,7 +119,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) & a_err='sv%build') goto 9999 end if - + !!$ if (.false.) then !!$ select type(ssv => sm%sv) !!$ class is(amg_d_l1_diag_solver_type) @@ -143,7 +165,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) sm%rho_ba = done end select end if - + if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),' end' From 23aabd794d3031ae805dc2d36dd1a9c41862cd46 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Mon, 20 Nov 2023 11:32:51 +0100 Subject: [PATCH 11/51] Defined new variant of polynomial smoother. --- amgprec/amg_d_poly_smoother.f90 | 2 +- .../amg_d_poly_smoother_apply_vect.f90 | 123 ++++++++++++------ .../impl/smoother/amg_d_poly_smoother_bld.f90 | 7 +- .../smoother/amg_d_poly_smoother_descr.f90 | 5 + 4 files changed, 90 insertions(+), 47 deletions(-) diff --git a/amgprec/amg_d_poly_smoother.f90 b/amgprec/amg_d_poly_smoother.f90 index 5ba83c24..a87fbb1b 100644 --- a/amgprec/amg_d_poly_smoother.f90 +++ b/amgprec/amg_d_poly_smoother.f90 @@ -63,7 +63,7 @@ module amg_d_poly_smoother integer(psb_ipk_) :: rho_estimate_iterations=10 type(psb_dspmat_type), pointer :: pa => null() real(psb_dpk_), allocatable :: poly_beta(:) - real(psb_dpk_), allocatable :: poly_a(:) + real(psb_dpk_) :: cf_a = dzero real(psb_dpk_) :: rho_ba = -done contains procedure, pass(sm) :: apply_v => amg_d_poly_smoother_apply_vect diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index 044c4fb5..9b085f62 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -63,7 +63,6 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_) :: np, me, i, err_act character :: trans_, init_ real(psb_dpk_) :: res, resdenum - real(psb_dpk_) :: cz, cr character(len=20) :: name='d_poly_smoother_apply_v' call psb_erractionsave(err_act) @@ -131,62 +130,100 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case(sm%variant) case(amg_poly_lottes_) - ! b == x - ! x == tx - ! - do i=1, sm%pdegree - ! B r_{k-1} - call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') - cz = (2*i*done-3)/(2*i*done+done) - cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(done,tz,done,tx,desc_data,info) - if (.false.) then - call psb_geaxpby(done,x,dzero,r,desc_data,info) - call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) - else - call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) - end if + block + real(psb_dpk_) :: cz, cr + ! b == x + ! x == tx + ! + do i=1, sm%pdegree + ! B r_{k-1} + call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + cz = (2*i*done-3)/(2*i*done+done) + cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(done,tz,done,tx,desc_data,info) + if (.false.) then + call psb_geaxpby(done,x,dzero,r,desc_data,info) + call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) + else + call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) + end if !!$ res = psb_genrm2(r,desc_data,info) !!$ write(0,*) 'Polynomial smoother ',i,res - ! x_k = x_{k-1} + z_k - end do + ! x_k = x_{k-1} + z_k + end do + end block case(amg_poly_lottes_beta_) - ! b == x - ! x == tx - ! - do i=1, sm%pdegree - ! B r_{k-1} - call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') - cz = (2*i*done-3)/(2*i*done+done) - cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(sm%poly_beta(i),tz,done,tx,desc_data,info) - if (.false.) then - call psb_geaxpby(done,x,dzero,r,desc_data,info) - call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) - else - call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) - end if + block + real(psb_dpk_) :: cz, cr + ! b == x + ! x == tx + ! + do i=1, sm%pdegree + ! B r_{k-1} + call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + cz = (2*i*done-3)/(2*i*done+done) + cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(sm%poly_beta(i),tz,done,tx,desc_data,info) + if (.false.) then + call psb_geaxpby(done,x,dzero,r,desc_data,info) + call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) + else + call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) + end if !!$ res = psb_genrm2(r,desc_data,info) !!$ write(0,*) 'Polynomial smoother ',i,res - ! x_k = x_{k-1} + z_k - end do - + ! x_k = x_{k-1} + z_k + end do + end block + case(amg_poly_new_) + 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 + call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + call psb_geaxpby((done/sm%rho_ba),ty,dzero,r,desc_data,info) + call psb_geaxpby((done/theta),r,dzero,tz,desc_data,info) + ! tz == d + do i=1, sm%pdegree + ! x_{k+1} = x_k + d_k + call psb_geaxpby(done,tz,done,tx,desc_data,info) + ! + ! r_{k-1} = r_k - (1/rho(BA)) B A d_k + call psb_spmm(done,sm%pa,tz,dzero,ty,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(-done,ty,done,r,desc_data,trans_,aux,wv(5:),info,init='Z') + + ! + ! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1} + rho = done/(2*sigma - rho_old) + call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother ',i,res + ! x_k = x_{k-1} + z_k + end do + end block + + 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index 4c587f4e..a7f0a72c 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -90,15 +90,16 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) end if case(amg_poly_new_) - if ((1<=sm%pdegree).and.(sm%pdegree<=6)) then - call psb_realloc(sm%pdegree,sm%poly_a,info) - sm%poly_a(1:sm%pdegree) = amg_d_poly_a_vect(1:sm%pdegree) + 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,& diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 index 0607064d..97521259 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 @@ -88,6 +88,11 @@ subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) 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 From dc15b931a0c2a391e944721a79033e55c2458813 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 21 Nov 2023 11:36:13 +0100 Subject: [PATCH 12/51] New test program. --- samples/advanced/pdegen/amg_d_pde3d.F90 | 70 +++++++++++-------------- 1 file changed, 31 insertions(+), 39 deletions(-) diff --git a/samples/advanced/pdegen/amg_d_pde3d.F90 b/samples/advanced/pdegen/amg_d_pde3d.F90 index 24631320..410b6e01 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.F90 +++ b/samples/advanced/pdegen/amg_d_pde3d.F90 @@ -80,7 +80,7 @@ program amg_d_pde3d implicit none ! input parameters - character(len=24) :: kmethd, ptype + character(len=20) :: kmethd, ptype character(len=5) :: afmt, pdecoeff integer(psb_ipk_) :: idim integer(psb_epk_) :: system_size @@ -120,21 +120,21 @@ program amg_d_pde3d ! preconditioner type character(len=40) :: descr ! verbose description of the prec - character(len=24) :: ptype ! preconditioner type + character(len=10) :: ptype ! preconditioner type integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level, ! AMG cycles for ML ! general AMG data - character(len=24) :: mlcycle ! AMG cycle type + character(len=16) :: mlcycle ! AMG cycle type integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner ! AMG aggregation - character(len=24) :: aggr_prol ! aggregation type: SMOOTHED, NONSMOOTHED - character(len=24) :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC - character(len=24) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP + character(len=16) :: aggr_prol ! aggregation type: SMOOTHED, NONSMOOTHED + character(len=16) :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC + character(len=16) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP integer(psb_ipk_) :: aggr_size ! Requested size of the aggregates for MATCHBOXP - character(len=24) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE - character(len=24) :: aggr_filter ! filtering: FILTER, NO_FILTER + character(len=16) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE + character(len=16) :: 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 @@ -142,43 +142,41 @@ program amg_d_pde3d integer(psb_ipk_) :: csizepp ! minimum size of coarsest matrix per process ! AMG smoother or pre-smoother; also 1-lev preconditioner - character(len=24) :: smther ! (pre-)smoother type: BJAC, AS + character(len=16) :: 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=24) :: pvariant ! Polynomial smoother variant integer(psb_ipk_) :: novr ! number of overlap layers - character(len=24) :: restr ! restriction over application of AS - character(len=24) :: prol ! prolongation over application of AS - character(len=24) :: solve ! local subsolver type: ILU, MILU, ILUT, + character(len=16) :: restr ! restriction over application of AS + character(len=16) :: prol ! prolongation over application of AS + character(len=16) :: solve ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps ! inner solver sweeps - character(len=24) :: variant ! AINV variant: LLK, etc + character(len=16) :: variant ! AINV variant: LLK, etc integer(psb_ipk_) :: fill ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill ! Inverse fill-in for INVK - real(psb_dpk_) :: thr ! threshold for ILUT factorization + real(psb_dpk_) :: thr ! threshold for ILUT factorization ! AMG post-smoother; ignored by 1-lev preconditioner - character(len=24) :: smther2 ! post-smoother type: BJAC, AS + character(len=16) :: smther2 ! post-smoother type: BJAC, AS integer(psb_ipk_) :: jsweeps2 ! post-smoother sweeps integer(psb_ipk_) :: degree2 ! degree for polynomial smoother - character(len=24) :: pvariant2 ! Polynomial smoother variant integer(psb_ipk_) :: novr2 ! number of overlap layers - character(len=24) :: restr2 ! restriction over application of AS - character(len=24) :: prol2 ! prolongation over application of AS - character(len=24) :: solve2 ! local subsolver type: ILU, MILU, ILUT, + character(len=16) :: restr2 ! restriction over application of AS + character(len=16) :: prol2 ! prolongation over application of AS + character(len=16) :: solve2 ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps2 ! inner solver sweeps - character(len=24) :: variant2 ! AINV variant: LLK, etc + character(len=16) :: variant2 ! AINV variant: LLK, etc integer(psb_ipk_) :: fill2 ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill2 ! Inverse fill-in for INVK - real(psb_dpk_) :: thr2 ! threshold for ILUT factorization + real(psb_dpk_) :: thr2 ! threshold for ILUT factorization ! coarsest-level solver - character(len=24) :: cmat ! coarsest matrix layout: REPL, DIST - character(len=24) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. + character(len=16) :: cmat ! coarsest matrix layout: REPL, DIST + character(len=16) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. ! mat.); UMF, MUMPS, SLU, ILU, ILUT, MILU ! (repl. mat.) - character(len=24) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT, + character(len=16) :: 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 @@ -200,7 +198,7 @@ program amg_d_pde3d ! other variables integer(psb_ipk_) :: info, i, k - character(len=24) :: name,ch_err + character(len=20) :: name,ch_err type(psb_d_csr_sparse_mat) :: amold info=psb_success_ @@ -293,8 +291,7 @@ program amg_d_pde3d 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) + call prec%set('smoother_degree', p_choice%degree, 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) @@ -342,8 +339,7 @@ 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) + call prec%set('smoother_degree', p_choice%degree, info) select case (psb_toupper(p_choice%smther)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') @@ -374,8 +370,7 @@ 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') + call prec%set('smoother_degree', p_choice%degree2, info,pos='post') select case (psb_toupper(p_choice%smther2)) case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS') ! do nothing @@ -412,6 +407,7 @@ program amg_d_pde3d call prec%set('coarse_sweeps', p_choice%cjswp, info) end select +!!$ call prec%descr(info,iout=psb_out_unit) ! build the preconditioner call psb_barrier(ctxt) @@ -591,8 +587,7 @@ 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) ! Degree of Polynomial smoother - call read_data(prec%pvariant,inp_unit) ! variant for Polynomial + call read_data(prec%degree,inp_unit) ! (pre-)smoother / 1-lev prec sweeps 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 @@ -605,13 +600,12 @@ 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) ! Degree of Polynomial smoother - call read_data(prec%pvariant2,inp_unit) ! Polynomial smoother variant + call read_data(prec%degree2,inp_unit) ! (post-)smoother sweeps 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 @@ -678,7 +672,6 @@ contains 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) @@ -692,7 +685,6 @@ contains 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) From 737ebb9a96975a9486dfec6b41c13bd9c534a6b5 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 21 Nov 2023 12:01:07 +0100 Subject: [PATCH 13/51] Test program working --- samples/advanced/pdegen/amg_d_pde3d.F90 | 55 ++++++++++++++----------- 1 file changed, 32 insertions(+), 23 deletions(-) diff --git a/samples/advanced/pdegen/amg_d_pde3d.F90 b/samples/advanced/pdegen/amg_d_pde3d.F90 index 410b6e01..10fc96e0 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.F90 +++ b/samples/advanced/pdegen/amg_d_pde3d.F90 @@ -125,16 +125,16 @@ program amg_d_pde3d integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level, ! AMG cycles for ML ! general AMG data - character(len=16) :: mlcycle ! AMG cycle type + character(len=32) :: mlcycle ! AMG cycle type integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner ! AMG aggregation - character(len=16) :: aggr_prol ! aggregation type: SMOOTHED, NONSMOOTHED - character(len=16) :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC - character(len=16) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP + 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=16) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE - character(len=16) :: aggr_filter ! filtering: FILTER, NO_FILTER + 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 @@ -142,41 +142,43 @@ program amg_d_pde3d integer(psb_ipk_) :: csizepp ! minimum size of coarsest matrix per process ! AMG smoother or pre-smoother; also 1-lev preconditioner - character(len=16) :: smther ! (pre-)smoother type: BJAC, AS + 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=16) :: restr ! restriction over application of AS - character(len=16) :: prol ! prolongation over application of AS - character(len=16) :: solve ! local subsolver type: ILU, MILU, ILUT, + character(len=32) :: restr ! restriction over application of AS + character(len=32) :: prol ! prolongation over application of AS + character(len=32) :: solve ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps ! inner solver sweeps - character(len=16) :: variant ! AINV variant: LLK, etc + character(len=32) :: variant ! AINV variant: LLK, etc integer(psb_ipk_) :: fill ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill ! Inverse fill-in for INVK real(psb_dpk_) :: thr ! threshold for ILUT factorization ! AMG post-smoother; ignored by 1-lev preconditioner - character(len=16) :: smther2 ! post-smoother type: BJAC, AS + 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=16) :: restr2 ! restriction over application of AS - character(len=16) :: prol2 ! prolongation over application of AS - character(len=16) :: solve2 ! local subsolver type: ILU, MILU, ILUT, + character(len=32) :: restr2 ! restriction over application of AS + character(len=32) :: prol2 ! prolongation over application of AS + character(len=32) :: solve2 ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps2 ! inner solver sweeps - character(len=16) :: variant2 ! AINV variant: LLK, etc + character(len=32) :: variant2 ! AINV variant: LLK, etc integer(psb_ipk_) :: fill2 ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill2 ! Inverse fill-in for INVK real(psb_dpk_) :: thr2 ! threshold for ILUT factorization ! coarsest-level solver - character(len=16) :: cmat ! coarsest matrix layout: REPL, DIST - character(len=16) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. + 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=16) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT, + 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 @@ -291,7 +293,8 @@ program amg_d_pde3d 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('smoother_degree', p_choice%degree, 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) @@ -339,7 +342,8 @@ 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('smoother_degree', p_choice%degree, 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') @@ -370,7 +374,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('smoother_degree', p_choice%degree2, 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 @@ -587,7 +592,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%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 @@ -601,6 +607,7 @@ contains 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 @@ -672,6 +679,7 @@ contains 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) @@ -685,6 +693,7 @@ contains 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) From 30a5c7be0350d6158a1307f0b06e8091b56e8643 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 22 Nov 2023 13:33:20 +0100 Subject: [PATCH 14/51] Added POLY smoothers, also in SAMPLES/ADVANCED --- amgprec/Makefile | 3 +- amgprec/amg_base_prec_type.F90 | 4 +- amgprec/impl/amg_cfile_prec_descr.f90 | 2 +- amgprec/impl/amg_cprecinit.F90 | 2 +- amgprec/impl/amg_dfile_prec_descr.f90 | 2 +- amgprec/impl/amg_dprecinit.F90 | 5 +- amgprec/impl/amg_sfile_prec_descr.f90 | 2 +- amgprec/impl/amg_sprecinit.F90 | 11 +- amgprec/impl/amg_zfile_prec_descr.f90 | 2 +- amgprec/impl/amg_zprecinit.F90 | 2 +- .../impl/level/amg_c_base_onelev_csetc.F90 | 9 +- .../impl/level/amg_d_base_onelev_csetc.F90 | 5 +- .../impl/level/amg_s_base_onelev_csetc.F90 | 14 +- .../impl/level/amg_z_base_onelev_csetc.F90 | 9 +- amgprec/impl/smoother/Makefile | 11 + .../amg_c_jac_smoother_apply_vect.f90 | 2 +- .../amg_d_jac_smoother_apply_vect.f90 | 11 +- .../amg_d_poly_smoother_apply_vect.f90 | 18 +- .../impl/smoother/amg_d_poly_smoother_bld.f90 | 56 +-- .../amg_d_poly_smoother_clear_data.f90 | 2 +- .../amg_d_poly_smoother_clone_settings.f90 | 8 +- .../smoother/amg_d_poly_smoother_csetc.f90 | 2 +- .../smoother/amg_d_poly_smoother_descr.f90 | 12 +- .../amg_s_jac_smoother_apply_vect.f90 | 2 +- .../amg_s_poly_smoother_apply_vect.f90 | 453 ++++++++++++++++++ .../impl/smoother/amg_s_poly_smoother_bld.f90 | 180 +++++++ .../amg_s_poly_smoother_clear_data.f90 | 70 +++ .../smoother/amg_s_poly_smoother_clone.f90 | 90 ++++ .../amg_s_poly_smoother_clone_settings.f90 | 102 ++++ .../impl/smoother/amg_s_poly_smoother_cnv.f90 | 77 +++ .../smoother/amg_s_poly_smoother_csetc.f90 | 76 +++ .../smoother/amg_s_poly_smoother_cseti.f90 | 92 ++++ .../smoother/amg_s_poly_smoother_csetr.f90 | 74 +++ .../smoother/amg_s_poly_smoother_descr.f90 | 108 +++++ .../impl/smoother/amg_s_poly_smoother_dmp.f90 | 90 ++++ .../amg_z_jac_smoother_apply_vect.f90 | 2 +- samples/advanced/pdegen/Makefile | 28 +- samples/advanced/pdegen/amg_d_pde2d.F90 | 94 ++-- .../advanced/pdegen/amg_d_pde2d_base_mod.f90 | 56 +-- .../advanced/pdegen/amg_d_pde2d_box_mod.f90 | 4 +- .../advanced/pdegen/amg_d_pde2d_exp_mod.f90 | 4 +- .../advanced/pdegen/amg_d_pde2d_gauss_mod.f90 | 89 ++++ samples/advanced/pdegen/amg_d_pde3d.F90 | 11 +- .../advanced/pdegen/amg_d_pde3d_base_mod.f90 | 72 +-- .../advanced/pdegen/amg_d_pde3d_box_mod.f90 | 101 ++++ .../advanced/pdegen/amg_d_pde3d_exp_mod.f90 | 4 +- .../advanced/pdegen/amg_d_pde3d_gauss_mod.f90 | 4 +- samples/advanced/pdegen/amg_s_pde2d.F90 | 94 ++-- .../advanced/pdegen/amg_s_pde2d_base_mod.f90 | 56 +-- .../advanced/pdegen/amg_s_pde2d_box_mod.f90 | 4 +- .../advanced/pdegen/amg_s_pde2d_exp_mod.f90 | 4 +- .../advanced/pdegen/amg_s_pde2d_gauss_mod.f90 | 89 ++++ samples/advanced/pdegen/amg_s_pde3d.F90 | 72 ++- .../advanced/pdegen/amg_s_pde3d_base_mod.f90 | 72 +-- .../advanced/pdegen/amg_s_pde3d_box_mod.f90 | 101 ++++ .../advanced/pdegen/amg_s_pde3d_exp_mod.f90 | 4 +- .../advanced/pdegen/amg_s_pde3d_gauss_mod.f90 | 4 +- samples/advanced/pdegen/runs/amg_pde2d.inp | 28 +- samples/advanced/pdegen/runs/amg_pde3d.inp | 14 +- 59 files changed, 2255 insertions(+), 364 deletions(-) create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_clear_data.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_clone.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_clone_settings.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_cnv.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_csetc.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_cseti.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_csetr.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 create mode 100644 amgprec/impl/smoother/amg_s_poly_smoother_dmp.f90 create mode 100644 samples/advanced/pdegen/amg_d_pde2d_gauss_mod.f90 create mode 100644 samples/advanced/pdegen/amg_d_pde3d_box_mod.f90 create mode 100644 samples/advanced/pdegen/amg_s_pde2d_gauss_mod.f90 create mode 100644 samples/advanced/pdegen/amg_s_pde3d_box_mod.f90 diff --git a/amgprec/Makefile b/amgprec/Makefile index 79842c27..c6ccb4b7 100644 --- a/amgprec/Makefile +++ b/amgprec/Makefile @@ -21,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 \ @@ -166,6 +166,7 @@ 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 5d75e274..3434d675 100644 --- a/amgprec/amg_base_prec_type.F90 +++ b/amgprec/amg_base_prec_type.F90 @@ -687,10 +687,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 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_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_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_dprecinit.F90 b/amgprec/impl/amg_dprecinit.F90 index 8f3c0cb6..176ceb0d 100644 --- a/amgprec/impl/amg_dprecinit.F90 +++ b/amgprec/impl/amg_dprecinit.F90 @@ -93,12 +93,13 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info) use psb_base_mod use amg_d_prec_mod, amg_protect_name => amg_dprecinit use amg_d_jac_smoother - use amg_d_poly_smoother use amg_d_as_smoother use amg_d_id_solver 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 @@ -156,7 +157,6 @@ 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 @@ -165,7 +165,6 @@ subroutine amg_dprecinit(ctxt,prec,ptype,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_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_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_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_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/amg_c_base_onelev_csetc.F90 b/amgprec/impl/level/amg_c_base_onelev_csetc.F90 index a372d972..12ed5ea6 100644 --- a/amgprec/impl/level/amg_c_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_csetc.F90 @@ -188,16 +188,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_d_base_onelev_csetc.F90 b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 index d4d37262..3b2e4f37 100644 --- a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 @@ -43,9 +43,9 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) use amg_d_dec_aggregator_mod use amg_d_symdec_aggregator_mod use amg_d_parmatch_aggregator_mod + use amg_d_poly_smoother use amg_d_jac_smoother use amg_d_as_smoother - use amg_d_poly_smoother use amg_d_diag_solver use amg_d_l1_diag_solver use amg_d_jac_solver @@ -85,7 +85,6 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold - type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold type(amg_d_jac_solver_type) :: amg_d_jac_solver_mold @@ -97,6 +96,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 @@ -161,7 +161,6 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) 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') diff --git a/amgprec/impl/level/amg_s_base_onelev_csetc.F90 b/amgprec/impl/level/amg_s_base_onelev_csetc.F90 index 60329291..f76d4b61 100644 --- a/amgprec/impl/level/amg_s_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_csetc.F90 @@ -43,6 +43,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx) use amg_s_dec_aggregator_mod use amg_s_symdec_aggregator_mod use amg_s_parmatch_aggregator_mod + use amg_s_poly_smoother use amg_s_jac_smoother use amg_s_as_smoother use amg_s_diag_solver @@ -89,6 +90,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 @@ -144,6 +146,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') @@ -189,16 +194,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_z_base_onelev_csetc.F90 b/amgprec/impl/level/amg_z_base_onelev_csetc.F90 index 5ca4233c..e0eddc4d 100644 --- a/amgprec/impl/level/amg_z_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_csetc.F90 @@ -200,16 +200,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/smoother/Makefile b/amgprec/impl/smoother/Makefile index 58884bc8..89a1906e 100644 --- a/amgprec/impl/smoother/Makefile +++ b/amgprec/impl/smoother/Makefile @@ -153,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 1c206c27..cafb6c8c 100644 --- a/amgprec/impl/smoother/amg_d_jac_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_jac_smoother_apply_vect.f90 @@ -109,7 +109,7 @@ subroutine amg_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if endif - if(.true..or.sm%checkres) then + if(sm%checkres) then call psb_geall(r,desc_data,info) call psb_geasb(r,desc_data,info) resdenum = psb_genrm2(x,desc_data,info) @@ -159,10 +159,7 @@ subroutine amg_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & a_err='wrong init to smoother_apply') goto 9999 end select -!!$ 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) -!!$ write(0,*) 'Jacobi smoother ',1,res + do i=1, sweeps-1 ! ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), @@ -176,10 +173,6 @@ subroutine amg_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit -!!$ 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) -!!$ write(0,*) 'Jacobi smoother ',i+1,res if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then call psb_geaxpby(done,x,dzero,r,desc_data,info) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index 9b085f62..a7a4202f 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -120,7 +120,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & a_err='invalid wv size in smoother_apply') goto 9999 end if - + sm%pdegree = sweeps associate(tx => wv(1), ty => wv(2), tz => wv(3), r => wv(4)) call psb_geaxpby(done,x,dzero,r,desc_data,info) @@ -135,7 +135,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! b == x ! x == tx ! - do i=1, sm%pdegree + do i=1, sweeps ! B r_{k-1} call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*done-3)/(2*i*done+done) @@ -163,7 +163,15 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! b == x ! x == tx ! - do i=1, sm%pdegree + if (allocated(sm%poly_beta)) then + if (size(sm%poly_beta) /= sweeps) deallocate(sm%poly_beta) + end if + if (.not.allocated(sm%poly_beta)) then + call psb_realloc(sweeps,sm%poly_beta,info) + sm%poly_beta(1:sweeps) = amg_d_poly_beta_mat(1:sweeps,sweeps) + end if + + do i=1, sweeps ! B r_{k-1} call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*done-3)/(2*i*done+done) @@ -190,6 +198,8 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! b == x ! x == tx ! + sm%cf_a = amg_d_poly_a_vect(sweeps) + theta = (done+sm%cf_a)/2 delta = (done-sm%cf_a)/2 sigma = theta/delta @@ -198,7 +208,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby((done/sm%rho_ba),ty,dzero,r,desc_data,info) call psb_geaxpby((done/theta),r,dzero,tz,desc_data,info) ! tz == d - do i=1, sm%pdegree + do i=1, sweeps ! x_{k+1} = x_k + d_k call psb_geaxpby(done,tz,done,tx,desc_data,info) ! diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index a7f0a72c..d9d39c03 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -74,39 +74,39 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) n_col = desc_a%get_local_cols() nrow_a = a%get_nrows() nztota = a%get_nzeros() + if (.false.) then + 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_) - 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 - if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then - !Ok - sm%cf_a = amg_d_poly_a_vect(sm%pdegree) - else + case default info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='invalid sm%degree for poly_a') + & a_err='invalid sm%variant') 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 - + end select + end if sm%pa => a if (.not.allocated(sm%sv)) then info = psb_err_internal_error_ diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_clear_data.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_clear_data.f90 index ac526bca..a6df5486 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_clear_data.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_clear_data.f90 @@ -44,7 +44,7 @@ subroutine amg_d_poly_smoother_clear_data(sm,info) 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_clear_data' + character(len=20) :: name='amg_d_poly_smoother_clear_data' call psb_erractionsave(err_act) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90 index 1fbdac37..d72cce67 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90 @@ -56,7 +56,13 @@ subroutine amg_d_poly_smoother_clone_settings(sm,smout,info) 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) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 index e61b09e3..3d0ac0fe 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_csetc.f90 @@ -38,7 +38,7 @@ subroutine amg_d_poly_smoother_csetc(sm,what,val,info,idx) use psb_base_mod - use amg_d_poly_smoother, amg_protect_nam => amg_d_poly_smoother_csetc + 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 index 97521259..1535388c 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 @@ -40,8 +40,6 @@ subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) use psb_base_mod use amg_d_diag_solver use amg_d_poly_smoother, amg_protect_name => amg_d_poly_smoother_descr - use amg_d_diag_solver - use amg_d_gs_solver Implicit None @@ -81,18 +79,18 @@ subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) 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_), ' 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_), ' 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) + !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_), ' Degree: ',sm%pdegree write(iout_,*) trim(prefix_), ' rho_ba: ',sm%rho_ba - write(iout_,*) trim(prefix_), ' Coefficient: ',sm%cf_a + !write(iout_,*) trim(prefix_), ' Coefficient: ',sm%cf_a case default write(iout_,*) trim(prefix_), ' variant: ','UNKNOWN???' end select 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..76be3e99 --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 @@ -0,0 +1,453 @@ +! +! +! 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 + 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 + ! + 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 + + 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 (me == 0) write(0,*) name,' Unimplemented apply_vect ' +!!$ info =psb_err_internal_error_ +!!$ call psb_errpush(info,& +!!$ & name,a_err='Error in sub_aply Polynomial not implemented') +!!$ goto 9999 + + 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 + sm%pdegree = sweeps + 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_) + block + real(psb_spk_) :: cz, cr + ! b == x + ! x == tx + ! + do i=1, sweeps + ! B r_{k-1} + call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + cz = (2*i*sone-3)/(2*i*sone+sone) + cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba) + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(sone,tz,sone,tx,desc_data,info) + if (.false.) then + call psb_geaxpby(sone,x,szero,r,desc_data,info) + call psb_spmm(-sone,sm%pa,tx,sone,r,desc_data,info,work=aux,trans=trans_) + else + call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_) + end if +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother ',i,res + ! x_k = x_{k-1} + z_k + end do + end block + + case(amg_poly_lottes_beta_) + + block + real(psb_spk_) :: cz, cr + ! b == x + ! x == tx + ! + if (allocated(sm%poly_beta)) then + if (size(sm%poly_beta) /= sweeps) deallocate(sm%poly_beta) + end if + if (.not.allocated(sm%poly_beta)) then + call psb_realloc(sweeps,sm%poly_beta,info) + sm%poly_beta(1:sweeps) = amg_d_poly_beta_mat(1:sweeps,sweeps) + end if + + do i=1, sweeps + ! B r_{k-1} + call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + cz = (2*i*sone-3)/(2*i*sone+sone) + cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba) + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(sm%poly_beta(i),tz,sone,tx,desc_data,info) + if (.false.) then + call psb_geaxpby(sone,x,szero,r,desc_data,info) + call psb_spmm(-sone,sm%pa,tx,sone,r,desc_data,info,work=aux,trans=trans_) + else + call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_) + end if +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother ',i,res + ! x_k = x_{k-1} + z_k + end do + end block + + case(amg_poly_new_) + block + real(psb_spk_) :: sigma, theta, delta, rho_old, rho + ! b == x + ! x == tx + ! + sm%cf_a = amg_d_poly_a_vect(sweeps) + + theta = (sone+sm%cf_a)/2 + delta = (sone-sm%cf_a)/2 + sigma = theta/delta + rho_old = sone/sigma + call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + call psb_geaxpby((sone/sm%rho_ba),ty,szero,r,desc_data,info) + call psb_geaxpby((sone/theta),r,szero,tz,desc_data,info) + ! tz == d + do i=1, sweeps + ! x_{k+1} = x_k + d_k + call psb_geaxpby(sone,tz,sone,tx,desc_data,info) + ! + ! r_{k-1} = r_k - (1/rho(BA)) B A d_k + call psb_spmm(sone,sm%pa,tz,szero,ty,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(-sone,ty,sone,r,desc_data,trans_,aux,wv(5:),info,init='Z') + + ! + ! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1} + rho = sone/(2*sigma - rho_old) + call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother ',i,res + ! x_k = x_{k-1} + z_k + end do + end block + + + 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.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then +!!$ ! if .not.sv%is_iterative, there's no need to pass init +!!$ call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,& +!!$ & name,a_err='Error in sub_aply Jacobi Sweeps = 1') +!!$ goto 9999 +!!$ endif +!!$ +!!$ else if (sweeps >= 0) then +!!$ select type (smsv => sm%sv) +!!$ class is (amg_s_diag_solver_type) +!!$ ! +!!$ ! This means we are dealing with a pure Jacobi smoother/solver. +!!$ ! +!!$ associate(tx => wv(1), ty => wv(2)) +!!$ select case (init_) +!!$ case('Z') +!!$ +!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') +!!$ +!!$ case('Y') +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info) +!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case('U') +!!$ if (.not.present(initu)) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='missing initu to smoother_apply') +!!$ goto 9999 +!!$ end if +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info) +!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case default +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='wrong init to smoother_apply') +!!$ goto 9999 +!!$ end select +!!$ +!!$ do i=1, sweeps-1 +!!$ ! +!!$ ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), +!!$ ! where is the diagonal and A the matrix. +!!$ ! +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ +!!$ if (info /= psb_success_) exit +!!$ +!!$ call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ 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_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ if( sm%printres ) then +!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) +!!$ end if +!!$ if ( res < sm%tol*resdenum ) then +!!$ if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & +!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) +!!$ exit +!!$ end if +!!$ end if +!!$ +!!$ end do +!!$ +!!$ +!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='subsolve with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ +!!$ end associate +!!$ +!!$ class default +!!$ ! +!!$ ! +!!$ ! Apply multiple sweeps of a block-Jacobi solver +!!$ ! to compute an approximate solution of a linear system. +!!$ ! +!!$ ! +!!$ if (size(wv) < 2) 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)) +!!$ +!!$ ! +!!$ ! Unroll the first iteration and fold it inside SELECT CASE +!!$ ! this will save one AXPBY and one SPMM when INIT=Z, and will be +!!$ ! significant when sweeps=1 (a common case) +!!$ ! +!!$ select case (init_) +!!$ case('Z') +!!$ +!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') +!!$ +!!$ case('Y') +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info) +!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case('U') +!!$ if (.not.present(initu)) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='missing initu to smoother_apply') +!!$ goto 9999 +!!$ end if +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info) +!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case default +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='wrong init to smoother_apply') +!!$ goto 9999 +!!$ end select +!!$ +!!$ do i=1, sweeps-1 +!!$ ! +!!$ ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the +!!$ ! block diagonal part and the remaining part of the local matrix +!!$ ! and Y(j) is the approximate solution at sweep j. +!!$ ! +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ +!!$ if (info /= psb_success_) exit +!!$ +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ 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_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ if( sm%printres ) then +!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) +!!$ end if +!!$ if (res < sm%tol*resdenum ) then +!!$ if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & +!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) +!!$ exit +!!$ end if +!!$ end if +!!$ +!!$ end do +!!$ +!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='subsolve with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ end associate +!!$ end select +!!$ +!!$ else +!!$ +!!$ info = psb_err_iarg_neg_ +!!$ call psb_errpush(info,name,& +!!$ & i_err=(/itwo,sweeps,izero,izero,izero/)) +!!$ goto 9999 +!!$ +!!$ endif +!!$ + if (.not.(4*n_col <= size(work))) then + deallocate(aux) + endif + +!!$ if(sm%checkres) then +!!$ call psb_gefree(r,desc_data,info) +!!$ end if + + 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..231136f1 --- /dev/null +++ b/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 @@ -0,0 +1,180 @@ +! +! +! 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() + if (.false.) then + 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 + end if + 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/samples/advanced/pdegen/Makefile b/samples/advanced/pdegen/Makefile index b5092a22..fc9a7f21 100644 --- a/samples/advanced/pdegen/Makefile +++ b/samples/advanced/pdegen/Makefile @@ -8,23 +8,27 @@ FINCLUDES=$(FMFLAG). $(FMFLAG)$(AMGMODDIR) $(FMFLAG)$(AMGINCDIR) $(PSBLAS_INCLUD LINKOPT= EXEDIR=./runs +DGEN2D=amg_d_pde2d_base_mod.o amg_d_pde2d_exp_mod.o amg_d_pde2d_gauss_mod.o amg_d_pde2d_box_mod.o +DGEN3D=amg_d_pde3d_base_mod.o amg_d_pde3d_exp_mod.o amg_d_pde3d_gauss_mod.o amg_d_pde3d_box_mod.o +SGEN2D=amg_s_pde2d_base_mod.o amg_s_pde2d_exp_mod.o amg_s_pde2d_gauss_mod.o amg_s_pde2d_box_mod.o +SGEN3D=amg_s_pde3d_base_mod.o amg_s_pde3d_exp_mod.o amg_s_pde3d_gauss_mod.o amg_s_pde3d_box_mod.o all: amg_s_pde3d amg_d_pde3d amg_s_pde2d amg_d_pde2d -amg_d_pde3d: amg_d_pde3d.o amg_d_genpde_mod.o amg_d_pde3d_base_mod.o amg_d_pde3d_exp_mod.o amg_d_pde3d_gauss_mod.o data_input.o - $(FLINK) $(LINKOPT) amg_d_pde3d.o amg_d_genpde_mod.o amg_d_pde3d_base_mod.o amg_d_pde3d_exp_mod.o amg_d_pde3d_gauss_mod.o data_input.o -o amg_d_pde3d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS) +amg_d_pde3d: amg_d_pde3d.o amg_d_genpde_mod.o $(DGEN3D) data_input.o + $(FLINK) $(LINKOPT) amg_d_pde3d.o amg_d_genpde_mod.o $(DGEN3D) data_input.o -o amg_d_pde3d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS) /bin/mv amg_d_pde3d $(EXEDIR) -amg_s_pde3d: amg_s_pde3d.o amg_s_genpde_mod.o amg_s_pde3d_base_mod.o amg_s_pde3d_exp_mod.o amg_s_pde3d_gauss_mod.o data_input.o - $(FLINK) $(LINKOPT) amg_s_pde3d.o amg_s_genpde_mod.o amg_s_pde3d_base_mod.o amg_s_pde3d_exp_mod.o amg_s_pde3d_gauss_mod.o data_input.o -o amg_s_pde3d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS) +amg_s_pde3d: amg_s_pde3d.o amg_s_genpde_mod.o $(SGEN3D) data_input.o + $(FLINK) $(LINKOPT) amg_s_pde3d.o amg_s_genpde_mod.o $(SGEN3D) data_input.o -o amg_s_pde3d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS) /bin/mv amg_s_pde3d $(EXEDIR) -amg_d_pde2d: amg_d_pde2d.o amg_d_genpde_mod.o amg_d_pde2d_base_mod.o amg_d_pde2d_exp_mod.o amg_d_pde2d_box_mod.o data_input.o - $(FLINK) $(LINKOPT) amg_d_pde2d.o amg_d_genpde_mod.o amg_d_pde2d_base_mod.o amg_d_pde2d_exp_mod.o amg_d_pde2d_box_mod.o data_input.o -o amg_d_pde2d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS) +amg_d_pde2d: amg_d_pde2d.o amg_d_genpde_mod.o $(DGEN2D) data_input.o + $(FLINK) $(LINKOPT) amg_d_pde2d.o amg_d_genpde_mod.o $(DGEN2D) data_input.o -o amg_d_pde2d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS) /bin/mv amg_d_pde2d $(EXEDIR) -amg_s_pde2d: amg_s_pde2d.o amg_s_genpde_mod.o amg_s_pde2d_base_mod.o amg_s_pde2d_exp_mod.o amg_s_pde2d_box_mod.o data_input.o - $(FLINK) $(LINKOPT) amg_s_pde2d.o amg_s_genpde_mod.o amg_s_pde2d_base_mod.o amg_s_pde2d_exp_mod.o amg_s_pde2d_box_mod.o data_input.o -o amg_s_pde2d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS) +amg_s_pde2d: amg_s_pde2d.o amg_s_genpde_mod.o $(SGEN2D) data_input.o + $(FLINK) $(LINKOPT) amg_s_pde2d.o amg_s_genpde_mod.o $(SGEN2D) data_input.o -o amg_s_pde2d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS) /bin/mv amg_s_pde2d $(EXEDIR) amg_d_pde3d_rebld: amg_d_pde3d_rebld.o data_input.o @@ -33,10 +37,10 @@ amg_d_pde3d_rebld: amg_d_pde3d_rebld.o data_input.o amg_d_pde3d.o amg_s_pde3d.o amg_d_pde2d.o amg_s_pde2d.o: data_input.o -amg_d_pde3d.o: amg_d_genpde_mod.o amg_d_pde3d_base_mod.o amg_d_pde3d_exp_mod.o amg_d_pde3d_gauss_mod.o -amg_s_pde3d.o: amg_s_genpde_mod.o amg_s_pde3d_base_mod.o amg_s_pde3d_exp_mod.o amg_s_pde3d_gauss_mod.o -amg_d_pde2d.o: amg_d_genpde_mod.o amg_d_pde2d_base_mod.o amg_d_pde2d_exp_mod.o amg_d_pde2d_box_mod.o -amg_s_pde2d.o: amg_s_genpde_mod.o amg_s_pde2d_base_mod.o amg_s_pde2d_exp_mod.o amg_s_pde2d_box_mod.o +amg_d_pde3d.o: amg_d_genpde_mod.o $(DGEN3D) +amg_s_pde3d.o: amg_s_genpde_mod.o $(SGEN3D) +amg_d_pde2d.o: amg_d_genpde_mod.o $(DGEN2D) +amg_s_pde2d.o: amg_s_genpde_mod.o $(SGEN2D) check: all cd runs && ./amg_d_pde2d 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)& @@ -332,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 @@ -362,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 @@ -577,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 @@ -589,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 @@ -659,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) @@ -671,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_pde2d_base_mod.f90 b/samples/advanced/pdegen/amg_d_pde2d_base_mod.f90 index a406e90e..e6613370 100644 --- a/samples/advanced/pdegen/amg_d_pde2d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde2d_base_mod.f90 @@ -38,52 +38,52 @@ module amg_d_pde2d_base_mod use psb_base_mod, only : psb_dpk_, dzero, done real(psb_dpk_), save, private :: epsilon=done/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm2d_base(dat) real(psb_dpk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm2d_base ! ! functions parametrizing the differential equation ! - function b1(x,y) + function b1_base(x,y) implicit none - real(psb_dpk_) :: b1 + real(psb_dpk_) :: b1_base real(psb_dpk_), intent(in) :: x,y - b1 = dzero/1.414_psb_dpk_ - end function b1 - function b2(x,y) + b1_base = dzero/1.414_psb_dpk_ + end function b1_base + function b2_base(x,y) implicit none - real(psb_dpk_) :: b2 + real(psb_dpk_) :: b2_base real(psb_dpk_), intent(in) :: x,y - b2 = dzero/1.414_psb_dpk_ - end function b2 - function c(x,y) + b2_base = dzero/1.414_psb_dpk_ + end function b2_base + function c_base(x,y) implicit none - real(psb_dpk_) :: c + real(psb_dpk_) :: c_base real(psb_dpk_), intent(in) :: x,y - c = dzero - end function c - function a1(x,y) + c_base = dzero + end function c_base + function a1_base(x,y) implicit none - real(psb_dpk_) :: a1 + real(psb_dpk_) :: a1_base real(psb_dpk_), intent(in) :: x,y - a1=done*epsilon - end function a1 - function a2(x,y) + a1_base=done*epsilon + end function a1_base + function a2_base(x,y) implicit none - real(psb_dpk_) :: a2 + real(psb_dpk_) :: a2_base real(psb_dpk_), intent(in) :: x,y - a2=done*epsilon - end function a2 - function g(x,y) + a2_base=done*epsilon + end function a2_base + function g_base(x,y) implicit none - real(psb_dpk_) :: g + real(psb_dpk_) :: g_base real(psb_dpk_), intent(in) :: x,y - g = dzero + g_base = dzero if (x == done) then - g = done + g_base = done else if (x == dzero) then - g = done + g_base = done end if - end function g + end function g_base end module amg_d_pde2d_base_mod diff --git a/samples/advanced/pdegen/amg_d_pde2d_box_mod.f90 b/samples/advanced/pdegen/amg_d_pde2d_box_mod.f90 index db743633..11d5770b 100644 --- a/samples/advanced/pdegen/amg_d_pde2d_box_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde2d_box_mod.f90 @@ -38,10 +38,10 @@ module amg_d_pde2d_box_mod use psb_base_mod, only : psb_dpk_, dzero, done real(psb_dpk_), save, private :: epsilon=done/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm2d_box(dat) real(psb_dpk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm2d_box ! ! functions parametrizing the differential equation ! diff --git a/samples/advanced/pdegen/amg_d_pde2d_exp_mod.f90 b/samples/advanced/pdegen/amg_d_pde2d_exp_mod.f90 index 5dab37bc..76a733fc 100644 --- a/samples/advanced/pdegen/amg_d_pde2d_exp_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde2d_exp_mod.f90 @@ -38,10 +38,10 @@ module amg_d_pde2d_exp_mod use psb_base_mod, only : psb_dpk_, done, dzero real(psb_dpk_), save, private :: epsilon=done/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm2d_exp(dat) real(psb_dpk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm2d_exp ! ! functions parametrizing the differential equation ! diff --git a/samples/advanced/pdegen/amg_d_pde2d_gauss_mod.f90 b/samples/advanced/pdegen/amg_d_pde2d_gauss_mod.f90 new file mode 100644 index 00000000..93b911ea --- /dev/null +++ b/samples/advanced/pdegen/amg_d_pde2d_gauss_mod.f90 @@ -0,0 +1,89 @@ +! +! +! 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. +! +module amg_d_pde2d_gauss_mod + use psb_base_mod, only : psb_dpk_, done, dzero + real(psb_dpk_), save, private :: epsilon=done/80 +contains + subroutine pde_set_parm2d_gauss(dat) + real(psb_dpk_), intent(in) :: dat + epsilon = dat + end subroutine pde_set_parm2d_gauss + ! + ! functions parametrizing the differential equation + ! + function b1_gauss(x,y) + implicit none + real(psb_dpk_) :: b1_gauss + real(psb_dpk_), intent(in) :: x,y + b1_gauss=done/sqrt(3.0_psb_dpk_)-2*x*exp(-(x**2+y**2)) + end function b1_gauss + function b2_gauss(x,y) + implicit none + real(psb_dpk_) :: b2_gauss + real(psb_dpk_), intent(in) :: x,y + b2_gauss=done/sqrt(3.0_psb_dpk_)-2*y*exp(-(x**2+y**2)) + end function b2_gauss + function c_gauss(x,y) + implicit none + real(psb_dpk_) :: c_gauss + real(psb_dpk_), intent(in) :: x,y + c_gauss=dzero + end function c_gauss + function a1_gauss(x,y) + implicit none + real(psb_dpk_) :: a1_gauss + real(psb_dpk_), intent(in) :: x,y + a1_gauss=epsilon*exp(-(x**2+y**2)) + end function a1_gauss + function a2_gauss(x,y) + implicit none + real(psb_dpk_) :: a2_gauss + real(psb_dpk_), intent(in) :: x,y + a2_gauss=epsilon*exp(-(x**2+y**2)) + end function a2_gauss + function g_gauss(x,y) + implicit none + real(psb_dpk_) :: g_gauss + real(psb_dpk_), intent(in) :: x,y + g_gauss = dzero + if (x == done) then + g_gauss = done + else if (x == dzero) then + g_gauss = done + end if + end function g_gauss +end module amg_d_pde2d_gauss_mod diff --git a/samples/advanced/pdegen/amg_d_pde3d.F90 b/samples/advanced/pdegen/amg_d_pde3d.F90 index 10fc96e0..8c4b7b6b 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.F90 +++ b/samples/advanced/pdegen/amg_d_pde3d.F90 @@ -72,6 +72,7 @@ program amg_d_pde3d use data_input use amg_d_pde3d_base_mod use amg_d_pde3d_exp_mod + use amg_d_pde3d_box_mod use amg_d_pde3d_gauss_mod use amg_d_genpde_mod #if defined(OPENMP) @@ -201,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_ @@ -247,10 +248,13 @@ program amg_d_pde3d select case(psb_toupper(trim(pdecoeff))) case("CONST") call amg_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& - & a1,a2,a3,b1,b2,b3,c,g,info) + & a1_base,a2_base,a3_base,b1_base,b2_base,b3_base,c_base,g_base,info) case("EXP") call amg_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& & a1_exp,a2_exp,a3_exp,b1_exp,b2_exp,b3_exp,c_exp,g_exp,info) + case("BOX") + call amg_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& + & a1_box,a2_box,a3_box,b1_box,b2_box,b3_box,c_box,g_box,info) case("GAUSS") call amg_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& & a1_gauss,a2_gauss,a3_gauss,b1_gauss,b2_gauss,b3_gauss,c_gauss,g_gauss,info) @@ -412,7 +416,6 @@ program amg_d_pde3d call prec%set('coarse_sweeps', p_choice%cjswp, info) end select -!!$ call prec%descr(info,iout=psb_out_unit) ! build the preconditioner call psb_barrier(ctxt) @@ -425,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') diff --git a/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 b/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 index 0eaf0a34..4e954654 100644 --- a/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 @@ -38,64 +38,64 @@ module amg_d_pde3d_base_mod use psb_base_mod, only : psb_dpk_, done, dzero real(psb_dpk_), save, private :: epsilon=done/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm3d_base(dat) real(psb_dpk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm3d_base ! ! functions parametrizing the differential equation ! - function b1(x,y,z) + function b1_base(x,y,z) implicit none - real(psb_dpk_) :: b1 + real(psb_dpk_) :: b1_base real(psb_dpk_), intent(in) :: x,y,z - b1=dzero/sqrt(3.0_psb_dpk_) - end function b1 - function b2(x,y,z) + b1_base=dzero/sqrt(3.0_psb_dpk_) + end function b1_base + function b2_base(x,y,z) implicit none - real(psb_dpk_) :: b2 + real(psb_dpk_) :: b2_base real(psb_dpk_), intent(in) :: x,y,z - b2=dzero/sqrt(3.0_psb_dpk_) - end function b2 - function b3(x,y,z) + b2_base=dzero/sqrt(3.0_psb_dpk_) + end function b2_base + function b3_base(x,y,z) implicit none - real(psb_dpk_) :: b3 + real(psb_dpk_) :: b3_base real(psb_dpk_), intent(in) :: x,y,z - b3=dzero/sqrt(3.0_psb_dpk_) - end function b3 - function c(x,y,z) + b3_base=dzero/sqrt(3.0_psb_dpk_) + end function b3_base + function c_base(x,y,z) implicit none - real(psb_dpk_) :: c + real(psb_dpk_) :: c_base real(psb_dpk_), intent(in) :: x,y,z - c=dzero - end function c - function a1(x,y,z) + c_base=dzero + end function c_base + function a1_base(x,y,z) implicit none - real(psb_dpk_) :: a1 + real(psb_dpk_) :: a1_base real(psb_dpk_), intent(in) :: x,y,z - a1=epsilon - end function a1 - function a2(x,y,z) + a1_base=epsilon + end function a1_base + function a2_base(x,y,z) implicit none - real(psb_dpk_) :: a2 + real(psb_dpk_) :: a2_base real(psb_dpk_), intent(in) :: x,y,z - a2=epsilon - end function a2 - function a3(x,y,z) + a2_base=epsilon + end function a2_base + function a3_base(x,y,z) implicit none - real(psb_dpk_) :: a3 + real(psb_dpk_) :: a3_base real(psb_dpk_), intent(in) :: x,y,z - a3=epsilon - end function a3 - function g(x,y,z) + a3_base=epsilon + end function a3_base + function g_base(x,y,z) implicit none - real(psb_dpk_) :: g + real(psb_dpk_) :: g_base real(psb_dpk_), intent(in) :: x,y,z - g = dzero + g_base = dzero if (x == done) then - g = done + g_base = done else if (x == dzero) then - g = done + g_base = done end if - end function g + end function g_base end module amg_d_pde3d_base_mod diff --git a/samples/advanced/pdegen/amg_d_pde3d_box_mod.f90 b/samples/advanced/pdegen/amg_d_pde3d_box_mod.f90 new file mode 100644 index 00000000..7062ad27 --- /dev/null +++ b/samples/advanced/pdegen/amg_d_pde3d_box_mod.f90 @@ -0,0 +1,101 @@ +! +! +! 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. +! +module amg_d_pde3d_box_mod + use psb_base_mod, only : psb_dpk_, done, dzero + real(psb_dpk_), save, private :: epsilon=done/80 +contains + subroutine pde_set_parm3d_box(dat) + real(psb_dpk_), intent(in) :: dat + epsilon = dat + end subroutine pde_set_parm3d_box + ! + ! functions parametrizing the differential equation + ! + function b1_box(x,y,z) + implicit none + real(psb_dpk_) :: b1_box + real(psb_dpk_), intent(in) :: x,y,z + b1_box=done/sqrt(3.0_psb_dpk_) + end function b1_box + function b2_box(x,y,z) + implicit none + real(psb_dpk_) :: b2_box + real(psb_dpk_), intent(in) :: x,y,z + b2_box=done/sqrt(3.0_psb_dpk_) + end function b2_box + function b3_box(x,y,z) + implicit none + real(psb_dpk_) :: b3_box + real(psb_dpk_), intent(in) :: x,y,z + b3_box=done/sqrt(3.0_psb_dpk_) + end function b3_box + function c_box(x,y,z) + implicit none + real(psb_dpk_) :: c_box + real(psb_dpk_), intent(in) :: x,y,z + c_box=dzero + end function c_box + function a1_box(x,y,z) + implicit none + real(psb_dpk_) :: a1_box + real(psb_dpk_), intent(in) :: x,y,z + a1_box=epsilon + end function a1_box + function a2_box(x,y,z) + implicit none + real(psb_dpk_) :: a2_box + real(psb_dpk_), intent(in) :: x,y,z + a2_box=epsilon + end function a2_box + function a3_box(x,y,z) + implicit none + real(psb_dpk_) :: a3_box + real(psb_dpk_), intent(in) :: x,y,z + a3_box=epsilon + end function a3_box + function g_box(x,y,z) + implicit none + real(psb_dpk_) :: g_box + real(psb_dpk_), intent(in) :: x,y,z + g_box= dzero + if (x == done) then + g_box = done + else if (x == dzero) then + g_box = done + end if + end function g_box +end module amg_d_pde3d_box_mod diff --git a/samples/advanced/pdegen/amg_d_pde3d_exp_mod.f90 b/samples/advanced/pdegen/amg_d_pde3d_exp_mod.f90 index e7bcf6ef..fea3b8a4 100644 --- a/samples/advanced/pdegen/amg_d_pde3d_exp_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde3d_exp_mod.f90 @@ -38,10 +38,10 @@ module amg_d_pde3d_exp_mod use psb_base_mod, only : psb_dpk_, done, dzero real(psb_dpk_), save, private :: epsilon=done/160 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm3d_exp(dat) real(psb_dpk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm3d_exp ! ! functions parametrizing the differential equation ! diff --git a/samples/advanced/pdegen/amg_d_pde3d_gauss_mod.f90 b/samples/advanced/pdegen/amg_d_pde3d_gauss_mod.f90 index 8dd5f71a..c2403131 100644 --- a/samples/advanced/pdegen/amg_d_pde3d_gauss_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde3d_gauss_mod.f90 @@ -38,10 +38,10 @@ module amg_d_pde3d_gauss_mod use psb_base_mod, only : psb_dpk_, done, dzero real(psb_dpk_), save, private :: epsilon=done/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm3d_gauss(dat) real(psb_dpk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm3d_gauss ! ! functions parametrizing the differential equation ! diff --git a/samples/advanced/pdegen/amg_s_pde2d.F90 b/samples/advanced/pdegen/amg_s_pde2d.F90 index f3842a65..bcc995ea 100644 --- a/samples/advanced/pdegen/amg_s_pde2d.F90 +++ b/samples/advanced/pdegen/amg_s_pde2d.F90 @@ -72,6 +72,7 @@ program amg_s_pde2d use amg_s_pde2d_base_mod use amg_s_pde2d_exp_mod use amg_s_pde2d_box_mod + use amg_s_pde2d_gauss_mod use amg_s_genpde_mod #if defined(OPENMP) use omp_lib @@ -124,60 +125,64 @@ program amg_s_pde2d integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level, ! AMG cycles for ML ! general AMG data - character(len=16) :: mlcycle ! AMG cycle type - integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner + character(len=32) :: mlcycle ! AMG cycle type + integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner ! AMG aggregation - character(len=16) :: aggr_prol ! aggregation type: SMOOTHED, NONSMOOTHED - character(len=16) :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC - character(len=16) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP - integer(psb_ipk_) :: aggr_size ! Requested size of the aggregates for MATCHBOXP - character(len=16) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE - character(len=16) :: aggr_filter ! filtering: FILTER, NO_FILTER - real(psb_spk_) :: mncrratio ! minimum aggregation ratio + 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 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=16) :: smther ! (pre-)smoother type: BJAC, AS + 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=16) :: restr ! restriction over application of AS - character(len=16) :: prol ! prolongation over application of AS - character(len=16) :: solve ! local subsolver type: ILU, MILU, ILUT, + character(len=32) :: restr ! restriction over application of AS + character(len=32) :: prol ! prolongation over application of AS + character(len=32) :: solve ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps ! inner solver sweeps - character(len=16) :: variant ! AINV variant: LLK, etc + character(len=32) :: variant ! AINV variant: LLK, etc integer(psb_ipk_) :: fill ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill ! Inverse fill-in for INVK real(psb_spk_) :: thr ! threshold for ILUT factorization ! AMG post-smoother; ignored by 1-lev preconditioner - character(len=16) :: smther2 ! post-smoother type: BJAC, AS + 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=16) :: restr2 ! restriction over application of AS - character(len=16) :: prol2 ! prolongation over application of AS - character(len=16) :: solve2 ! local subsolver type: ILU, MILU, ILUT, + character(len=32) :: restr2 ! restriction over application of AS + character(len=32) :: prol2 ! prolongation over application of AS + character(len=32) :: solve2 ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps2 ! inner solver sweeps - character(len=16) :: variant2 ! AINV variant: LLK, etc + character(len=32) :: variant2 ! AINV variant: LLK, etc integer(psb_ipk_) :: fill2 ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill2 ! Inverse fill-in for INVK real(psb_spk_) :: thr2 ! threshold for ILUT factorization ! coarsest-level solver - character(len=16) :: cmat ! coarsest matrix layout: REPL, DIST - character(len=16) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. - ! mat.); UMF, MUMPS, SLU, ILU, ILUT, MILU - ! (repl. mat.) - character(len=16) :: 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. @@ -241,13 +246,16 @@ program amg_s_pde2d select case(psb_toupper(trim(pdecoeff))) case("CONST") call amg_gen_pde2d(ctxt,idim,a,b,x,desc_a,afmt,& - & a1,a2,b1,b2,c,g,info) + & a1_base,a2_base,b1_base,b2_base,c_base,g_base,info) case("EXP") call amg_gen_pde2d(ctxt,idim,a,b,x,desc_a,afmt,& & a1_exp,a2_exp,b1_exp,b2_exp,c_exp,g_exp,info) case("BOX") call amg_gen_pde2d(ctxt,idim,a,b,x,desc_a,afmt,& & a1_box,a2_box,b1_box,b2_box,c_box,g_box,info) + case("GAUSS") + call amg_gen_pde2d(ctxt,idim,a,b,x,desc_a,afmt,& + & a1_gauss,a2_gauss,b1_gauss,b2_gauss,c_gauss,g_gauss,info) case default info=psb_err_from_subroutine_ ch_err='amg_gen_pdecoeff' @@ -281,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) @@ -308,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)& @@ -332,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 @@ -362,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 @@ -577,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 @@ -589,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 @@ -659,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) @@ -671,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_pde2d_base_mod.f90 b/samples/advanced/pdegen/amg_s_pde2d_base_mod.f90 index 462c6154..d5cbc6d0 100644 --- a/samples/advanced/pdegen/amg_s_pde2d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde2d_base_mod.f90 @@ -38,52 +38,52 @@ module amg_s_pde2d_base_mod use psb_base_mod, only : psb_spk_, szero, sone real(psb_spk_), save, private :: epsilon=sone/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm2d_base(dat) real(psb_spk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm2d_base ! ! functions parametrizing the differential equation ! - function b1(x,y) + function b1_base(x,y) implicit none - real(psb_spk_) :: b1 + real(psb_spk_) :: b1_base real(psb_spk_), intent(in) :: x,y - b1 = szero/1.414_psb_spk_ - end function b1 - function b2(x,y) + b1_base = szero/1.414_psb_spk_ + end function b1_base + function b2_base(x,y) implicit none - real(psb_spk_) :: b2 + real(psb_spk_) :: b2_base real(psb_spk_), intent(in) :: x,y - b2 = szero/1.414_psb_spk_ - end function b2 - function c(x,y) + b2_base = szero/1.414_psb_spk_ + end function b2_base + function c_base(x,y) implicit none - real(psb_spk_) :: c + real(psb_spk_) :: c_base real(psb_spk_), intent(in) :: x,y - c = szero - end function c - function a1(x,y) + c_base = szero + end function c_base + function a1_base(x,y) implicit none - real(psb_spk_) :: a1 + real(psb_spk_) :: a1_base real(psb_spk_), intent(in) :: x,y - a1=sone*epsilon - end function a1 - function a2(x,y) + a1_base=sone*epsilon + end function a1_base + function a2_base(x,y) implicit none - real(psb_spk_) :: a2 + real(psb_spk_) :: a2_base real(psb_spk_), intent(in) :: x,y - a2=sone*epsilon - end function a2 - function g(x,y) + a2_base=sone*epsilon + end function a2_base + function g_base(x,y) implicit none - real(psb_spk_) :: g + real(psb_spk_) :: g_base real(psb_spk_), intent(in) :: x,y - g = szero + g_base = szero if (x == sone) then - g = sone + g_base = sone else if (x == szero) then - g = sone + g_base = sone end if - end function g + end function g_base end module amg_s_pde2d_base_mod diff --git a/samples/advanced/pdegen/amg_s_pde2d_box_mod.f90 b/samples/advanced/pdegen/amg_s_pde2d_box_mod.f90 index 9183521b..c36f8eb0 100644 --- a/samples/advanced/pdegen/amg_s_pde2d_box_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde2d_box_mod.f90 @@ -38,10 +38,10 @@ module amg_s_pde2d_box_mod use psb_base_mod, only : psb_spk_, szero, sone real(psb_spk_), save, private :: epsilon=sone/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm2d_box(dat) real(psb_spk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm2d_box ! ! functions parametrizing the differential equation ! diff --git a/samples/advanced/pdegen/amg_s_pde2d_exp_mod.f90 b/samples/advanced/pdegen/amg_s_pde2d_exp_mod.f90 index 3657546d..acc786b2 100644 --- a/samples/advanced/pdegen/amg_s_pde2d_exp_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde2d_exp_mod.f90 @@ -38,10 +38,10 @@ module amg_s_pde2d_exp_mod use psb_base_mod, only : psb_spk_, sone, szero real(psb_spk_), save, private :: epsilon=sone/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm2d_exp(dat) real(psb_spk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm2d_exp ! ! functions parametrizing the differential equation ! diff --git a/samples/advanced/pdegen/amg_s_pde2d_gauss_mod.f90 b/samples/advanced/pdegen/amg_s_pde2d_gauss_mod.f90 new file mode 100644 index 00000000..dd234d66 --- /dev/null +++ b/samples/advanced/pdegen/amg_s_pde2d_gauss_mod.f90 @@ -0,0 +1,89 @@ +! +! +! 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. +! +module amg_s_pde2d_gauss_mod + use psb_base_mod, only : psb_spk_, sone, szero + real(psb_spk_), save, private :: epsilon=sone/80 +contains + subroutine pde_set_parm2d_gauss(dat) + real(psb_spk_), intent(in) :: dat + epsilon = dat + end subroutine pde_set_parm2d_gauss + ! + ! functions parametrizing the differential equation + ! + function b1_gauss(x,y) + implicit none + real(psb_spk_) :: b1_gauss + real(psb_spk_), intent(in) :: x,y + b1_gauss=sone/sqrt(3.0_psb_spk_)-2*x*exp(-(x**2+y**2)) + end function b1_gauss + function b2_gauss(x,y) + implicit none + real(psb_spk_) :: b2_gauss + real(psb_spk_), intent(in) :: x,y + b2_gauss=sone/sqrt(3.0_psb_spk_)-2*y*exp(-(x**2+y**2)) + end function b2_gauss + function c_gauss(x,y) + implicit none + real(psb_spk_) :: c_gauss + real(psb_spk_), intent(in) :: x,y + c_gauss=szero + end function c_gauss + function a1_gauss(x,y) + implicit none + real(psb_spk_) :: a1_gauss + real(psb_spk_), intent(in) :: x,y + a1_gauss=epsilon*exp(-(x**2+y**2)) + end function a1_gauss + function a2_gauss(x,y) + implicit none + real(psb_spk_) :: a2_gauss + real(psb_spk_), intent(in) :: x,y + a2_gauss=epsilon*exp(-(x**2+y**2)) + end function a2_gauss + function g_gauss(x,y) + implicit none + real(psb_spk_) :: g_gauss + real(psb_spk_), intent(in) :: x,y + g_gauss = szero + if (x == sone) then + g_gauss = sone + else if (x == szero) then + g_gauss = sone + end if + end function g_gauss +end module amg_s_pde2d_gauss_mod diff --git a/samples/advanced/pdegen/amg_s_pde3d.F90 b/samples/advanced/pdegen/amg_s_pde3d.F90 index 97abad28..fe53cd8b 100644 --- a/samples/advanced/pdegen/amg_s_pde3d.F90 +++ b/samples/advanced/pdegen/amg_s_pde3d.F90 @@ -72,6 +72,7 @@ program amg_s_pde3d use data_input use amg_s_pde3d_base_mod use amg_s_pde3d_exp_mod + use amg_s_pde3d_box_mod use amg_s_pde3d_gauss_mod use amg_s_genpde_mod #if defined(OPENMP) @@ -125,16 +126,16 @@ program amg_s_pde3d integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level, ! AMG cycles for ML ! general AMG data - character(len=16) :: mlcycle ! AMG cycle type + character(len=32) :: mlcycle ! AMG cycle type integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner ! AMG aggregation - character(len=16) :: aggr_prol ! aggregation type: SMOOTHED, NONSMOOTHED - character(len=16) :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC - character(len=16) :: aggr_type ! Type of aggregation SOC1, SOC2, MATCHBOXP + 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=16) :: aggr_ord ! ordering for aggregation: NATURAL, DEGREE - character(len=16) :: aggr_filter ! filtering: FILTER, NO_FILTER + 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 @@ -142,39 +143,43 @@ program amg_s_pde3d integer(psb_ipk_) :: csizepp ! minimum size of coarsest matrix per process ! AMG smoother or pre-smoother; also 1-lev preconditioner - character(len=16) :: smther ! (pre-)smoother type: BJAC, AS + 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=16) :: restr ! restriction over application of AS - character(len=16) :: prol ! prolongation over application of AS - character(len=16) :: solve ! local subsolver type: ILU, MILU, ILUT, + character(len=32) :: restr ! restriction over application of AS + character(len=32) :: prol ! prolongation over application of AS + character(len=32) :: solve ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps ! inner solver sweeps - character(len=16) :: variant ! AINV variant: LLK, etc + character(len=32) :: variant ! AINV variant: LLK, etc integer(psb_ipk_) :: fill ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill ! Inverse fill-in for INVK real(psb_spk_) :: thr ! threshold for ILUT factorization ! AMG post-smoother; ignored by 1-lev preconditioner - character(len=16) :: smther2 ! post-smoother type: BJAC, AS + 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=16) :: restr2 ! restriction over application of AS - character(len=16) :: prol2 ! prolongation over application of AS - character(len=16) :: solve2 ! local subsolver type: ILU, MILU, ILUT, + character(len=32) :: restr2 ! restriction over application of AS + character(len=32) :: prol2 ! prolongation over application of AS + character(len=32) :: solve2 ! local subsolver type: ILU, MILU, ILUT, ! UMF, MUMPS, SLU, FWGS, BWGS, JAC integer(psb_ipk_) :: ssweeps2 ! inner solver sweeps - character(len=16) :: variant2 ! AINV variant: LLK, etc + character(len=32) :: variant2 ! AINV variant: LLK, etc integer(psb_ipk_) :: fill2 ! fill-in for incomplete LU factorization integer(psb_ipk_) :: invfill2 ! Inverse fill-in for INVK real(psb_spk_) :: thr2 ! threshold for ILUT factorization ! coarsest-level solver - character(len=16) :: cmat ! coarsest matrix layout: REPL, DIST - character(len=16) :: csolve ! coarsest-lev solver: BJAC, SLUDIST (distr. + 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=16) :: csbsolve ! coarsest-lev local subsolver: ILU, ILUT, + 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 @@ -197,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_ @@ -243,10 +248,13 @@ program amg_s_pde3d select case(psb_toupper(trim(pdecoeff))) case("CONST") call amg_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& - & a1,a2,a3,b1,b2,b3,c,g,info) + & a1_base,a2_base,a3_base,b1_base,b2_base,b3_base,c_base,g_base,info) case("EXP") call amg_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& & a1_exp,a2_exp,a3_exp,b1_exp,b2_exp,b3_exp,c_exp,g_exp,info) + case("BOX") + call amg_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& + & a1_box,a2_box,a3_box,b1_box,b2_box,b3_box,c_box,g_box,info) case("GAUSS") call amg_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& & a1_gauss,a2_gauss,a3_gauss,b1_gauss,b2_gauss,b3_gauss,c_gauss,g_gauss,info) @@ -285,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) @@ -336,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 @@ -366,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 @@ -414,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') @@ -581,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 @@ -593,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 @@ -663,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) @@ -675,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_pde3d_base_mod.f90 b/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 index 0ce83989..3dbd039f 100644 --- a/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 @@ -38,64 +38,64 @@ module amg_s_pde3d_base_mod use psb_base_mod, only : psb_spk_, sone, szero real(psb_spk_), save, private :: epsilon=sone/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm3d_base(dat) real(psb_spk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm3d_base ! ! functions parametrizing the differential equation ! - function b1(x,y,z) + function b1_base(x,y,z) implicit none - real(psb_spk_) :: b1 + real(psb_spk_) :: b1_base real(psb_spk_), intent(in) :: x,y,z - b1=sone/sqrt(3.0_psb_spk_) - end function b1 - function b2(x,y,z) + b1_base=szero/sqrt(3.0_psb_spk_) + end function b1_base + function b2_base(x,y,z) implicit none - real(psb_spk_) :: b2 + real(psb_spk_) :: b2_base real(psb_spk_), intent(in) :: x,y,z - b2=sone/sqrt(3.0_psb_spk_) - end function b2 - function b3(x,y,z) + b2_base=szero/sqrt(3.0_psb_spk_) + end function b2_base + function b3_base(x,y,z) implicit none - real(psb_spk_) :: b3 + real(psb_spk_) :: b3_base real(psb_spk_), intent(in) :: x,y,z - b3=sone/sqrt(3.0_psb_spk_) - end function b3 - function c(x,y,z) + b3_base=szero/sqrt(3.0_psb_spk_) + end function b3_base + function c_base(x,y,z) implicit none - real(psb_spk_) :: c + real(psb_spk_) :: c_base real(psb_spk_), intent(in) :: x,y,z - c=szero - end function c - function a1(x,y,z) + c_base=szero + end function c_base + function a1_base(x,y,z) implicit none - real(psb_spk_) :: a1 + real(psb_spk_) :: a1_base real(psb_spk_), intent(in) :: x,y,z - a1=epsilon - end function a1 - function a2(x,y,z) + a1_base=epsilon + end function a1_base + function a2_base(x,y,z) implicit none - real(psb_spk_) :: a2 + real(psb_spk_) :: a2_base real(psb_spk_), intent(in) :: x,y,z - a2=epsilon - end function a2 - function a3(x,y,z) + a2_base=epsilon + end function a2_base + function a3_base(x,y,z) implicit none - real(psb_spk_) :: a3 + real(psb_spk_) :: a3_base real(psb_spk_), intent(in) :: x,y,z - a3=epsilon - end function a3 - function g(x,y,z) + a3_base=epsilon + end function a3_base + function g_base(x,y,z) implicit none - real(psb_spk_) :: g + real(psb_spk_) :: g_base real(psb_spk_), intent(in) :: x,y,z - g = szero + g_base = szero if (x == sone) then - g = sone + g_base = sone else if (x == szero) then - g = sone + g_base = sone end if - end function g + end function g_base end module amg_s_pde3d_base_mod diff --git a/samples/advanced/pdegen/amg_s_pde3d_box_mod.f90 b/samples/advanced/pdegen/amg_s_pde3d_box_mod.f90 new file mode 100644 index 00000000..e0a1a5e3 --- /dev/null +++ b/samples/advanced/pdegen/amg_s_pde3d_box_mod.f90 @@ -0,0 +1,101 @@ +! +! +! 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. +! +module amg_s_pde3d_box_mod + use psb_base_mod, only : psb_spk_, sone, szero + real(psb_spk_), save, private :: epsilon=sone/80 +contains + subroutine pde_set_parm3d_box(dat) + real(psb_spk_), intent(in) :: dat + epsilon = dat + end subroutine pde_set_parm3d_box + ! + ! functions parametrizing the differential equation + ! + function b1_box(x,y,z) + implicit none + real(psb_spk_) :: b1_box + real(psb_spk_), intent(in) :: x,y,z + b1_box=sone/sqrt(3.0_psb_spk_) + end function b1_box + function b2_box(x,y,z) + implicit none + real(psb_spk_) :: b2_box + real(psb_spk_), intent(in) :: x,y,z + b2_box=sone/sqrt(3.0_psb_spk_) + end function b2_box + function b3_box(x,y,z) + implicit none + real(psb_spk_) :: b3_box + real(psb_spk_), intent(in) :: x,y,z + b3_box=sone/sqrt(3.0_psb_spk_) + end function b3_box + function c_box(x,y,z) + implicit none + real(psb_spk_) :: c_box + real(psb_spk_), intent(in) :: x,y,z + c_box=szero + end function c_box + function a1_box(x,y,z) + implicit none + real(psb_spk_) :: a1_box + real(psb_spk_), intent(in) :: x,y,z + a1_box=epsilon + end function a1_box + function a2_box(x,y,z) + implicit none + real(psb_spk_) :: a2_box + real(psb_spk_), intent(in) :: x,y,z + a2_box=epsilon + end function a2_box + function a3_box(x,y,z) + implicit none + real(psb_spk_) :: a3_box + real(psb_spk_), intent(in) :: x,y,z + a3_box=epsilon + end function a3_box + function g_box(x,y,z) + implicit none + real(psb_spk_) :: g_box + real(psb_spk_), intent(in) :: x,y,z + g_box= szero + if (x == sone) then + g_box = sone + else if (x == szero) then + g_box = sone + end if + end function g_box +end module amg_s_pde3d_box_mod diff --git a/samples/advanced/pdegen/amg_s_pde3d_exp_mod.f90 b/samples/advanced/pdegen/amg_s_pde3d_exp_mod.f90 index 8ec96d00..d1f8fbea 100644 --- a/samples/advanced/pdegen/amg_s_pde3d_exp_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde3d_exp_mod.f90 @@ -38,10 +38,10 @@ module amg_s_pde3d_exp_mod use psb_base_mod, only : psb_spk_, sone, szero real(psb_spk_), save, private :: epsilon=sone/160 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm3d_exp(dat) real(psb_spk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm3d_exp ! ! functions parametrizing the differential equation ! diff --git a/samples/advanced/pdegen/amg_s_pde3d_gauss_mod.f90 b/samples/advanced/pdegen/amg_s_pde3d_gauss_mod.f90 index fa6362e0..d7bb81ab 100644 --- a/samples/advanced/pdegen/amg_s_pde3d_gauss_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde3d_gauss_mod.f90 @@ -38,10 +38,10 @@ module amg_s_pde3d_gauss_mod use psb_base_mod, only : psb_spk_, sone, szero real(psb_spk_), save, private :: epsilon=sone/80 contains - subroutine pde_set_parm(dat) + subroutine pde_set_parm3d_gauss(dat) real(psb_spk_), intent(in) :: dat epsilon = dat - end subroutine pde_set_parm + end subroutine pde_set_parm3d_gauss ! ! functions parametrizing the differential equation ! 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 61e99a04..cb3b0819 100644 --- a/samples/advanced/pdegen/runs/amg_pde3d.inp +++ b/samples/advanced/pdegen/runs/amg_pde3d.inp @@ -1,7 +1,7 @@ %%%%%%%%%%% General arguments % Lines starting with % are ignored. CSR ! Storage format CSR COO JAD 0150 ! IDIM; domain size. Linear system size is IDIM**3 -CONST ! PDECOEFF: CONST, EXP, GAUSS 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 @@ -12,16 +12,16 @@ CG ! Iterative method: BiCGSTAB BiCGSTABL BiCG CG CGS F 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) %%%%%%%%%%%%%%%% +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 % -%%%%%%%%%%% First smoother (for all levels but coarsest) %%%%%%%%%%%%%%%% -L1-JACOBI ! 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 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG @@ -32,7 +32,7 @@ LLK ! AINV variant 1 ! Inverse Fill level P for INVK 1.d-4 ! Threshold T for ILU(T,P) %%%%%%%%%%% Second smoother, always ignored for non-ML %%%%%%%%%%%%%%%% -L1-JACOBI ! Second (post) smoother, ignored if NONE +NONE ! Second (post) smoother, ignored if NONE 6 ! Number of sweeps for (post) smoother 1 ! degree for polynomial smoother POLY_LOTTES_BETA ! Polynomial variant From ccef85819226051dee29f2541958699f6b390597 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 22 Nov 2023 14:45:16 +0100 Subject: [PATCH 15/51] Cleanup dead code --- .../amg_d_poly_smoother_apply_vect.f90 | 210 +----------------- .../amg_s_poly_smoother_apply_vect.f90 | 210 +----------------- 2 files changed, 10 insertions(+), 410 deletions(-) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index a7a4202f..b248a460 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -108,11 +108,6 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if endif -!!$ if (me == 0) write(0,*) name,' Unimplemented apply_vect ' -!!$ info =psb_err_internal_error_ -!!$ call psb_errpush(info,& -!!$ & name,a_err='Error in sub_aply Polynomial not implemented') -!!$ goto 9999 if (size(wv) < 4) then info = psb_err_internal_error_ @@ -150,8 +145,8 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother ',i,res +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother LOTTES ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -186,8 +181,8 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother ',i,res +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother LOTTES_BETA ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -221,7 +216,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& rho = done/(2*sigma - rho_old) call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) !!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother ',i,res +!!$ write(0,*) 'Polynomial smoother NEW ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -244,205 +239,10 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate - - - -!!$ if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then -!!$ ! if .not.sv%is_iterative, there's no need to pass init -!!$ call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_internal_error_,& -!!$ & name,a_err='Error in sub_aply Jacobi Sweeps = 1') -!!$ goto 9999 -!!$ endif -!!$ -!!$ else if (sweeps >= 0) then -!!$ select type (smsv => sm%sv) -!!$ class is (amg_d_diag_solver_type) -!!$ ! -!!$ ! This means we are dealing with a pure Jacobi smoother/solver. -!!$ ! -!!$ associate(tx => wv(1), ty => wv(2)) -!!$ select case (init_) -!!$ case('Z') -!!$ -!!$ call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') -!!$ -!!$ case('Y') -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_geaxpby(done,y,dzero,ty,desc_data,info) -!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case('U') -!!$ if (.not.present(initu)) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='missing initu to smoother_apply') -!!$ goto 9999 -!!$ end if -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_geaxpby(done,initu,dzero,ty,desc_data,info) -!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case default -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='wrong init to smoother_apply') -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, sweeps-1 -!!$ ! -!!$ ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), -!!$ ! where is the diagonal and A the matrix. -!!$ ! -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ -!!$ if (info /= psb_success_) exit -!!$ -!!$ call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ 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_spmm(-done,sm%pa,ty,done,r,desc_data,info) -!!$ res = psb_genrm2(r,desc_data,info) -!!$ if( sm%printres ) then -!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) -!!$ end if -!!$ if ( res < sm%tol*resdenum ) then -!!$ if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & -!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) -!!$ exit -!!$ end if -!!$ end if -!!$ -!!$ end do -!!$ -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='subsolve with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ end associate -!!$ -!!$ class default -!!$ ! -!!$ ! -!!$ ! Apply multiple sweeps of a block-Jacobi solver -!!$ ! to compute an approximate solution of a linear system. -!!$ ! -!!$ ! -!!$ if (size(wv) < 2) 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)) -!!$ -!!$ ! -!!$ ! Unroll the first iteration and fold it inside SELECT CASE -!!$ ! this will save one AXPBY and one SPMM when INIT=Z, and will be -!!$ ! significant when sweeps=1 (a common case) -!!$ ! -!!$ select case (init_) -!!$ case('Z') -!!$ -!!$ call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') -!!$ -!!$ case('Y') -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_geaxpby(done,y,dzero,ty,desc_data,info) -!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case('U') -!!$ if (.not.present(initu)) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='missing initu to smoother_apply') -!!$ goto 9999 -!!$ end if -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_geaxpby(done,initu,dzero,ty,desc_data,info) -!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case default -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='wrong init to smoother_apply') -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, sweeps-1 -!!$ ! -!!$ ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the -!!$ ! block diagonal part and the remaining part of the local matrix -!!$ ! and Y(j) is the approximate solution at sweep j. -!!$ ! -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ -!!$ if (info /= psb_success_) exit -!!$ -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ 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_spmm(-done,sm%pa,ty,done,r,desc_data,info) -!!$ res = psb_genrm2(r,desc_data,info) -!!$ if( sm%printres ) then -!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) -!!$ end if -!!$ if (res < sm%tol*resdenum ) then -!!$ if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & -!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) -!!$ exit -!!$ end if -!!$ end if -!!$ -!!$ end do -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='subsolve with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if -!!$ -!!$ end associate -!!$ end select -!!$ -!!$ else -!!$ -!!$ info = psb_err_iarg_neg_ -!!$ call psb_errpush(info,name,& -!!$ & i_err=(/itwo,sweeps,izero,izero,izero/)) -!!$ goto 9999 -!!$ -!!$ endif -!!$ if (.not.(4*n_col <= size(work))) then deallocate(aux) endif -!!$ if(sm%checkres) then -!!$ call psb_gefree(r,desc_data,info) -!!$ end if - call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 index 76be3e99..835e7eae 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 @@ -108,11 +108,6 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if endif -!!$ if (me == 0) write(0,*) name,' Unimplemented apply_vect ' -!!$ info =psb_err_internal_error_ -!!$ call psb_errpush(info,& -!!$ & name,a_err='Error in sub_aply Polynomial not implemented') -!!$ goto 9999 if (size(wv) < 4) then info = psb_err_internal_error_ @@ -150,8 +145,8 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_) end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother ',i,res +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother LOTTES ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -186,8 +181,8 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_) end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother ',i,res +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother LOTTES_BETA ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -221,7 +216,7 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& rho = sone/(2*sigma - rho_old) call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) !!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother ',i,res +!!$ write(0,*) 'Polynomial smoother NEW ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -244,205 +239,10 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate - - - -!!$ if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then -!!$ ! if .not.sv%is_iterative, there's no need to pass init -!!$ call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_internal_error_,& -!!$ & name,a_err='Error in sub_aply Jacobi Sweeps = 1') -!!$ goto 9999 -!!$ endif -!!$ -!!$ else if (sweeps >= 0) then -!!$ select type (smsv => sm%sv) -!!$ class is (amg_s_diag_solver_type) -!!$ ! -!!$ ! This means we are dealing with a pure Jacobi smoother/solver. -!!$ ! -!!$ associate(tx => wv(1), ty => wv(2)) -!!$ select case (init_) -!!$ case('Z') -!!$ -!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') -!!$ -!!$ case('Y') -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info) -!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case('U') -!!$ if (.not.present(initu)) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='missing initu to smoother_apply') -!!$ goto 9999 -!!$ end if -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info) -!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case default -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='wrong init to smoother_apply') -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, sweeps-1 -!!$ ! -!!$ ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), -!!$ ! where is the diagonal and A the matrix. -!!$ ! -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ -!!$ if (info /= psb_success_) exit -!!$ -!!$ call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ 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_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) -!!$ res = psb_genrm2(r,desc_data,info) -!!$ if( sm%printres ) then -!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) -!!$ end if -!!$ if ( res < sm%tol*resdenum ) then -!!$ if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & -!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) -!!$ exit -!!$ end if -!!$ end if -!!$ -!!$ end do -!!$ -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='subsolve with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ end associate -!!$ -!!$ class default -!!$ ! -!!$ ! -!!$ ! Apply multiple sweeps of a block-Jacobi solver -!!$ ! to compute an approximate solution of a linear system. -!!$ ! -!!$ ! -!!$ if (size(wv) < 2) 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)) -!!$ -!!$ ! -!!$ ! Unroll the first iteration and fold it inside SELECT CASE -!!$ ! this will save one AXPBY and one SPMM when INIT=Z, and will be -!!$ ! significant when sweeps=1 (a common case) -!!$ ! -!!$ select case (init_) -!!$ case('Z') -!!$ -!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') -!!$ -!!$ case('Y') -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info) -!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case('U') -!!$ if (.not.present(initu)) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='missing initu to smoother_apply') -!!$ goto 9999 -!!$ end if -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info) -!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case default -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='wrong init to smoother_apply') -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, sweeps-1 -!!$ ! -!!$ ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the -!!$ ! block diagonal part and the remaining part of the local matrix -!!$ ! and Y(j) is the approximate solution at sweep j. -!!$ ! -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ -!!$ if (info /= psb_success_) exit -!!$ -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ 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_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) -!!$ res = psb_genrm2(r,desc_data,info) -!!$ if( sm%printres ) then -!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) -!!$ end if -!!$ if (res < sm%tol*resdenum ) then -!!$ if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & -!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) -!!$ exit -!!$ end if -!!$ end if -!!$ -!!$ end do -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='subsolve with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if -!!$ -!!$ end associate -!!$ end select -!!$ -!!$ else -!!$ -!!$ info = psb_err_iarg_neg_ -!!$ call psb_errpush(info,name,& -!!$ & i_err=(/itwo,sweeps,izero,izero,izero/)) -!!$ goto 9999 -!!$ -!!$ endif -!!$ if (.not.(4*n_col <= size(work))) then deallocate(aux) endif -!!$ if(sm%checkres) then -!!$ call psb_gefree(r,desc_data,info) -!!$ end if - call psb_erractionrestore(err_act) return From 47bafd7fe757988cc3e46772b7446943d32c3c05 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 28 Nov 2023 14:00:24 +0100 Subject: [PATCH 16/51] Add missing file --- amgprec/amg_s_poly_smoother.f90 | 374 ++++++++++++++++++++++++++++++++ 1 file changed, 374 insertions(+) create mode 100644 amgprec/amg_s_poly_smoother.f90 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 From 54d608d2dd06e637efb280868bdc862b7ffccb6f Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Thu, 1 Feb 2024 14:50:49 +0100 Subject: [PATCH 17/51] Isolated under ifdef buggy matching --- amgprec/impl/aggregator/MatchBoxPC.cpp | 3 +- amgprec/impl/aggregator/MatchBoxPC.h | 16 ++++ ...mEdgesLinearSearchMesgBndlSmallMateCMP.cpp | 11 +-- amgprec/impl/aggregator/clean.cpp | 3 +- .../impl/aggregator/computeCandidateMate.cpp | 7 +- amgprec/impl/aggregator/extractUChunk.cpp | 5 +- amgprec/impl/aggregator/findOwnerOfGhost.cpp | 3 +- amgprec/impl/aggregator/initialize.cpp | 5 +- amgprec/impl/aggregator/isAlreadyMatched.cpp | 7 +- .../parallelComputeCandidateMateB.cpp | 3 +- amgprec/impl/aggregator/processCrossEdge.cpp | 5 +- .../impl/aggregator/processExposedVertex.cpp | 27 ++++--- .../aggregator/processMatchedVertices.cpp | 79 ++++++++++--------- .../processMatchedVerticesAndSendMessages.cpp | 76 +++++++++--------- amgprec/impl/aggregator/processMessages.cpp | 14 ++-- amgprec/impl/aggregator/queueTransfer.cpp | 3 +- .../impl/aggregator/sendBundledMessages.cpp | 9 ++- 17 files changed, 155 insertions(+), 121 deletions(-) diff --git a/amgprec/impl/aggregator/MatchBoxPC.cpp b/amgprec/impl/aggregator/MatchBoxPC.cpp index 90b448dc..37a879be 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.cpp +++ b/amgprec/impl/aggregator/MatchBoxPC.cpp @@ -72,8 +72,9 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge, double tmr = MPI_Wtime(); #endif -#define OMP +// Rimosso per tornare al vecchio matching #define OMP #ifdef OMP + fprintf(stderr,"Warning: using buggy OpenMP matching!\n"); dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge, verLocPtr, verLocInd, edgeLocWeight, verDistance, Mate, diff --git a/amgprec/impl/aggregator/MatchBoxPC.h b/amgprec/impl/aggregator/MatchBoxPC.h index a1fddb59..35cab21d 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.h +++ b/amgprec/impl/aggregator/MatchBoxPC.h @@ -59,7 +59,11 @@ #include #include #include +#ifdef OMP +// 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" @@ -174,6 +178,10 @@ extern "C" #define MilanRealMin MINUS_INFINITY #endif +#ifdef OMP +/* 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); @@ -420,6 +428,14 @@ extern "C" MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent, MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time, MilanLongInt *ph1_card, MilanLongInt *ph2_card); +#endif + + +#ifndef OMP + //Function of find the owner of a ghost vertex using binary search: + inline MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance, + MilanInt myRank, MilanInt numProcs); +#endif void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC( MilanLongInt NLVer, MilanLongInt NLEdge, diff --git a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp index 49b366a6..b086edad 100644 --- a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp +++ b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP // *********************************************************************** // // MatchboxP: A C++ library for approximate weighted matching @@ -222,7 +222,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( cout << myRank << " Finished initialization" << endl; fflush(stdout); #endif - + startTime = MPI_Wtime(); ///////////////////////////////////////////////////////////////////////////////////////// @@ -391,7 +391,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( cout << myRank << " Finished sendBundles" << endl; fflush(stdout); #endif - + *ph1_card = myCard; // Cardinality at the end of Phase-1 startTime = MPI_Wtime(); ///////////////////////////////////////////////////////////////////////////////////////// @@ -422,7 +422,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( /////////////////////////////////////////////////////////////////////////////////// /////////////////////////// PROCESS MATCHED VERTICES ////////////////////////////// /////////////////////////////////////////////////////////////////////////////////// - + processMatchedVerticesAndSendMessages(NLVer, UChunkBeingProcessed, U, @@ -456,7 +456,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( comm, &msgActual, Message); - + ///////////////////////// END OF PROCESS MATCHED VERTICES ///////////////////////// //// BREAK IF NO MESSAGES EXPECTED ///////// @@ -552,3 +552,4 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( #endif #endif +#endif diff --git a/amgprec/impl/aggregator/clean.cpp b/amgprec/impl/aggregator/clean.cpp index f316aee7..018469e4 100644 --- a/amgprec/impl/aggregator/clean.cpp +++ b/amgprec/impl/aggregator/clean.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP // TODO comment void clean(MilanLongInt NLVer, @@ -89,3 +89,4 @@ void clean(MilanLongInt NLVer, } } } +#endif diff --git a/amgprec/impl/aggregator/computeCandidateMate.cpp b/amgprec/impl/aggregator/computeCandidateMate.cpp index 7d4e7ce8..39ce8db1 100644 --- a/amgprec/impl/aggregator/computeCandidateMate.cpp +++ b/amgprec/impl/aggregator/computeCandidateMate.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP /** * Execute the research fr the Candidate Mate without controlling if the vertices are already matched. * Returns the vertices with the highest weight @@ -60,7 +60,7 @@ MilanLongInt computeCandidateMate(MilanLongInt adj1, for (k = adj1; k < adj2; k++) { if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap)) continue; - + if ((edgeLocWeight[k] > heaviestEdgeWt) || ((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k]))) { heaviestEdgeWt = edgeLocWeight[k]; @@ -68,6 +68,7 @@ MilanLongInt computeCandidateMate(MilanLongInt adj1, } } // 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..0986dfb6 100644 --- a/amgprec/impl/aggregator/extractUChunk.cpp +++ b/amgprec/impl/aggregator/extractUChunk.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP void extractUChunk( vector &UChunkBeingProcessed, vector &U, @@ -28,4 +28,5 @@ void extractUChunk( } } // End of critical U // End of critical U -} \ No newline at end of file +} +#endif diff --git a/amgprec/impl/aggregator/findOwnerOfGhost.cpp b/amgprec/impl/aggregator/findOwnerOfGhost.cpp index b9d60614..81c18822 100644 --- a/amgprec/impl/aggregator/findOwnerOfGhost.cpp +++ b/amgprec/impl/aggregator/findOwnerOfGhost.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP /// Find the owner of a ghost node: MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance, MilanInt myRank, MilanInt numProcs) @@ -27,3 +27,4 @@ MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance, return Current; } // End of findOwnerOfGhost() +#endif diff --git a/amgprec/impl/aggregator/initialize.cpp b/amgprec/impl/aggregator/initialize.cpp index 17a4169e..3f0f1a10 100644 --- a/amgprec/impl/aggregator/initialize.cpp +++ b/amgprec/impl/aggregator/initialize.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP void initialize(MilanLongInt NLVer, MilanLongInt NLEdge, MilanLongInt StartIndex, MilanLongInt EndIndex, MilanLongInt *numGhostEdges, @@ -291,7 +291,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); @@ -302,3 +302,4 @@ void initialize(MilanLongInt NLVer, MilanLongInt NLEdge, } // End of single region } // End of parallel region } +#endif diff --git a/amgprec/impl/aggregator/isAlreadyMatched.cpp b/amgprec/impl/aggregator/isAlreadyMatched.cpp index a7d65c15..de5f2f18 100644 --- a/amgprec/impl/aggregator/isAlreadyMatched.cpp +++ b/amgprec/impl/aggregator/isAlreadyMatched.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP /** * //TODO documentation * @param k @@ -32,7 +32,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 +43,5 @@ bool isAlreadyMatched(MilanLongInt node, val = Mate[node - StartIndex]; return val >= 0; // Already matched -} \ No newline at end of file +} +#endif diff --git a/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp b/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp index ffb8d2a3..f5429bf4 100644 --- a/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp +++ b/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer, MilanLongInt *verLocPtr, MilanLongInt *verLocInd, @@ -25,3 +25,4 @@ void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer, } } } +#endif diff --git a/amgprec/impl/aggregator/processCrossEdge.cpp b/amgprec/impl/aggregator/processCrossEdge.cpp index e844f127..d7c72d42 100644 --- a/amgprec/impl/aggregator/processCrossEdge.cpp +++ b/amgprec/impl/aggregator/processCrossEdge.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP void PROCESS_CROSS_EDGE(MilanLongInt *edge, MilanLongInt *S) { @@ -21,4 +21,5 @@ void PROCESS_CROSS_EDGE(MilanLongInt *edge, #endif // End: PARALLEL_PROCESS_CROSS_EDGE_B -} \ No newline at end of file +} +#endif diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index 2b38ec7a..c7ac4703 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, MilanLongInt *candidateMate, MilanLongInt *verLocInd, @@ -29,7 +29,7 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, vector &privateQGhostVtx, vector &privateQMsgType, vector &privateQOwner) -{ +{ MilanLongInt v = -1, k = -1, w = -1, adj11 = 0, adj12 = 0, k1 = 0; MilanInt ghostOwner = 0, option, igw; @@ -79,7 +79,7 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, Ghost2LocalMap); candidateMate[v] = w; } - + if (w >= 0) { (*myCard)++; if ((w < StartIndex) || (w > EndIndex)) { // w is a ghost vertex @@ -88,29 +88,29 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, 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 critical processExposed - + } // End of if(w >=0) else { // This piece of code is executed a really small amount of times @@ -131,17 +131,17 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, // assert(ghostOwner != -1); // assert(ghostOwner != myRank); 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: @@ -193,3 +193,4 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, } // End of parallel region } +#endif diff --git a/amgprec/impl/aggregator/processMatchedVertices.cpp b/amgprec/impl/aggregator/processMatchedVertices.cpp index d9363c39..d88199a6 100644 --- a/amgprec/impl/aggregator/processMatchedVertices.cpp +++ b/amgprec/impl/aggregator/processMatchedVertices.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP void processMatchedVertices( MilanLongInt NLVer, vector &UChunkBeingProcessed, @@ -58,29 +58,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); @@ -102,27 +102,27 @@ void processMatchedVertices( 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 >= 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 @@ -130,7 +130,7 @@ void processMatchedVertices( 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); @@ -146,7 +146,7 @@ void processMatchedVertices( } // 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) @@ -155,7 +155,7 @@ void processMatchedVertices( option = 5; // u is local } // End of critical } // End of Else //A Ghost Vertex - + switch (option) { case -1: @@ -165,7 +165,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 << ") "; @@ -174,7 +174,7 @@ 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); @@ -182,7 +182,7 @@ void processMatchedVertices( PCounter[ghostOwner]++; (*NumMessagesBundled)++; (*msgInd)++; - + privateQLocalVtx.push_back(v); privateQGhostVtx.push_back(w); privateQMsgType.push_back(REQUEST); @@ -191,7 +191,7 @@ void processMatchedVertices( case 3: privateU.push_back(v); privateU.push_back(w); - + (*myCard)++; break; case 4: @@ -201,94 +201,95 @@ 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); - + 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()); } - + privateU.clear(); - + #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()); } - + 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 } +#endif diff --git a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp index 469d7a16..4a9cfcba 100644 --- a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp +++ b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp @@ -1,4 +1,5 @@ #include "MatchBoxPC.h" +#ifdef OMP //#define DEBUG_HANG_ void processMatchedVerticesAndSendMessages( MilanLongInt NLVer, @@ -63,29 +64,29 @@ 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); @@ -107,28 +108,28 @@ void processMatchedVerticesAndSendMessages( 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 @@ -136,7 +137,7 @@ void processMatchedVerticesAndSendMessages( 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); @@ -152,7 +153,7 @@ void processMatchedVerticesAndSendMessages( } // 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) @@ -161,7 +162,7 @@ void processMatchedVerticesAndSendMessages( option = 5; // u is local } // End of critical } // End of Else //A Ghost Vertex - + switch (option) { case -1: @@ -179,20 +180,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); @@ -210,94 +211,94 @@ 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); - + #endif } // End of parallel region - + // Send the messages #ifdef DEBUG_HANG_ cout << myRank<<" Sending: "<(), ghostOwner, ComputeTag, comm); //cout << myRank<<" Sending to "<(), ghostOwner, ComputeTag, comm); @@ -306,3 +307,4 @@ void processMatchedVerticesAndSendMessages( cout << myRank<<" Done sending messages"< EndIndex)) { cout << "\n(" << myRank << ") From ReceiveBuffer: This should not happen: u= " << u << " v= " << v << " Type= " << message_type << " StartIndex " << StartIndex << " EndIndex " << EndIndex << endl; @@ -160,7 +161,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_ @@ -188,7 +189,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 ) @@ -249,7 +250,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 @@ -310,6 +311,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 33c65749..e51095da 100644 --- a/amgprec/impl/aggregator/queueTransfer.cpp +++ b/amgprec/impl/aggregator/queueTransfer.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP void queuesTransfer(vector &U, vector &privateU, vector &QLocalVtx, @@ -34,3 +34,4 @@ void queuesTransfer(vector &U, privateQOwner.clear(); } +#endif diff --git a/amgprec/impl/aggregator/sendBundledMessages.cpp b/amgprec/impl/aggregator/sendBundledMessages.cpp index 80a88b94..919dc7e9 100644 --- a/amgprec/impl/aggregator/sendBundledMessages.cpp +++ b/amgprec/impl/aggregator/sendBundledMessages.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" - +#ifdef OMP void sendBundledMessages(MilanLongInt *numGhostEdges, MilanInt *BufferSize, MilanLongInt *Buffer, @@ -62,7 +62,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 +84,7 @@ void sendBundledMessages(MilanLongInt *numGhostEdges, PCounter[QOwner[i]]++; } } - + // Send the Bundled Messages: Use ISend #pragma omp task depend(out \ : SRequest, SStatus) @@ -101,7 +101,7 @@ void sendBundledMessages(MilanLongInt *numGhostEdges, exit(1); } } - + // Send the Messages #pragma omp task depend(inout \ : SRequest, PSizeInfoMessages, PCumulative) depend(out \ @@ -207,3 +207,4 @@ void sendBundledMessages(MilanLongInt *numGhostEdges, } } } +#endif From ea8974f88c59246b6a4a4581779115190d7a5644 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Fri, 2 Feb 2024 19:25:21 +0100 Subject: [PATCH 18/51] Fixed build and apply to actually use degree --- .../amg_d_poly_smoother_apply_vect.f90 | 38 ++++++++--------- .../impl/smoother/amg_d_poly_smoother_bld.f90 | 21 +++++----- .../smoother/amg_d_poly_smoother_descr.f90 | 42 +++++++++---------- .../amg_s_poly_smoother_apply_vect.f90 | 38 ++++++++--------- .../impl/smoother/amg_s_poly_smoother_bld.f90 | 21 +++++----- .../smoother/amg_s_poly_smoother_descr.f90 | 42 +++++++++---------- 6 files changed, 100 insertions(+), 102 deletions(-) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index b248a460..358636d8 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -49,7 +49,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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 + 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 @@ -115,22 +115,22 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & a_err='invalid wv size in smoother_apply') goto 9999 end if - sm%pdegree = sweeps + 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() + call tz%zero() select case(sm%variant) case(amg_poly_lottes_) - block + block real(psb_dpk_) :: cz, cr - ! b == x + ! b == x ! x == tx - ! - do i=1, sweeps + ! + do i=1, sm%pdegree ! B r_{k-1} call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*done-3)/(2*i*done+done) @@ -153,20 +153,20 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& case(amg_poly_lottes_beta_) - block + block real(psb_dpk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! if (allocated(sm%poly_beta)) then - if (size(sm%poly_beta) /= sweeps) deallocate(sm%poly_beta) + if (size(sm%poly_beta) /= sm%pdegree) deallocate(sm%poly_beta) end if if (.not.allocated(sm%poly_beta)) then - call psb_realloc(sweeps,sm%poly_beta,info) - sm%poly_beta(1:sweeps) = amg_d_poly_beta_mat(1:sweeps,sweeps) + 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, sweeps + do i=1, sm%pdegree ! B r_{k-1} call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*done-3)/(2*i*done+done) @@ -186,14 +186,14 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! x_k = x_{k-1} + z_k end do end block - + case(amg_poly_new_) - block + block real(psb_dpk_) :: sigma, theta, delta, rho_old, rho - ! b == x + ! b == x ! x == tx ! - sm%cf_a = amg_d_poly_a_vect(sweeps) + theta = (done+sm%cf_a)/2 delta = (done-sm%cf_a)/2 @@ -203,10 +203,10 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby((done/sm%rho_ba),ty,dzero,r,desc_data,info) call psb_geaxpby((done/theta),r,dzero,tz,desc_data,info) ! tz == d - do i=1, sweeps + do i=1, sm%pdegree ! x_{k+1} = x_k + d_k call psb_geaxpby(done,tz,done,tx,desc_data,info) - ! + ! ! r_{k-1} = r_k - (1/rho(BA)) B A d_k call psb_spmm(done,sm%pa,tz,dzero,ty,desc_data,info,work=aux,trans=trans_) call sm%sv%apply(-done,ty,done,r,desc_data,trans_,aux,wv(5:),info,init='Z') diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index d9d39c03..8408beff 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -56,7 +56,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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(:) + 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 @@ -74,8 +74,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) n_col = desc_a%get_local_cols() nrow_a = a%get_nrows() nztota = a%get_nzeros() - if (.false.) then - select case(sm%variant) + select case(sm%variant) case(amg_poly_lottes_) ! do nothing case(amg_poly_lottes_beta_) @@ -89,7 +88,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if case(amg_poly_new_) - + write(psb_out_unit,*) "Nella fase di build sm%pdegree = ",sm%pdegree if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then !Ok sm%cf_a = amg_d_poly_a_vect(sm%pdegree) @@ -100,15 +99,15 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if - case default + case default info = psb_err_internal_error_ call psb_errpush(info,name,& & a_err='invalid sm%variant') goto 9999 end select - end if + sm%pa => a - if (.not.allocated(sm%sv)) then + if (.not.allocated(sm%sv)) then info = psb_err_internal_error_ call psb_errpush(info,name,& & a_err='unallocated sm%sv') @@ -121,7 +120,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if -!!$ if (.false.) then +!!$ if (.false.) then !!$ select type(ssv => sm%sv) !!$ class is(amg_d_l1_diag_solver_type) !!$ da = a%arwsum(info) @@ -129,7 +128,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) !!$ 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 +!!$ sm%rho_ba = done !!$ end select !!$ else if (sm%rho_ba <= dzero) then @@ -153,9 +152,9 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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_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} + 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 index 1535388c..469e1bb6 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) use psb_base_mod @@ -59,13 +59,13 @@ subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) call psb_erractionsave(err_act) info = psb_success_ - if (present(coarse)) then + if (present(coarse)) then coarse_ = coarse else coarse_ = .false. end if - if (present(iout)) then - iout_ = iout + if (present(iout)) then + iout_ = iout else iout_ = psb_out_unit endif @@ -78,19 +78,19 @@ subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) 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_), ' 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_), ' 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) + 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_), ' Degree: ',sm%pdegree write(iout_,*) trim(prefix_), ' rho_ba: ',sm%rho_ba - !write(iout_,*) trim(prefix_), ' Coefficient: ',sm%cf_a + write(iout_,*) trim(prefix_), ' Coefficient: ',sm%cf_a case default write(iout_,*) trim(prefix_), ' variant: ','UNKNOWN???' end select diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 index 835e7eae..b2b7b7df 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 @@ -49,7 +49,7 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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 + 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 @@ -115,22 +115,22 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& & a_err='invalid wv size in smoother_apply') goto 9999 end if - sm%pdegree = sweeps + 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() + call tz%zero() select case(sm%variant) case(amg_poly_lottes_) - block + block real(psb_spk_) :: cz, cr - ! b == x + ! b == x ! x == tx - ! - do i=1, sweeps + ! + do i=1, sm%pdegree ! B r_{k-1} call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*sone-3)/(2*i*sone+sone) @@ -153,20 +153,20 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& case(amg_poly_lottes_beta_) - block + block real(psb_spk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! if (allocated(sm%poly_beta)) then - if (size(sm%poly_beta) /= sweeps) deallocate(sm%poly_beta) + if (size(sm%poly_beta) /= sm%pdegree) deallocate(sm%poly_beta) end if if (.not.allocated(sm%poly_beta)) then - call psb_realloc(sweeps,sm%poly_beta,info) - sm%poly_beta(1:sweeps) = amg_d_poly_beta_mat(1:sweeps,sweeps) + 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, sweeps + do i=1, sm%pdegree ! B r_{k-1} call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*sone-3)/(2*i*sone+sone) @@ -186,14 +186,14 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! x_k = x_{k-1} + z_k end do end block - + case(amg_poly_new_) - block + block real(psb_spk_) :: sigma, theta, delta, rho_old, rho - ! b == x + ! b == x ! x == tx ! - sm%cf_a = amg_d_poly_a_vect(sweeps) + theta = (sone+sm%cf_a)/2 delta = (sone-sm%cf_a)/2 @@ -203,10 +203,10 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby((sone/sm%rho_ba),ty,szero,r,desc_data,info) call psb_geaxpby((sone/theta),r,szero,tz,desc_data,info) ! tz == d - do i=1, sweeps + do i=1, sm%pdegree ! x_{k+1} = x_k + d_k call psb_geaxpby(sone,tz,sone,tx,desc_data,info) - ! + ! ! r_{k-1} = r_k - (1/rho(BA)) B A d_k call psb_spmm(sone,sm%pa,tz,szero,ty,desc_data,info,work=aux,trans=trans_) call sm%sv%apply(-sone,ty,sone,r,desc_data,trans_,aux,wv(5:),info,init='Z') diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 index 231136f1..3b0f5846 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 @@ -56,7 +56,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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(:) + 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 @@ -74,8 +74,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) n_col = desc_a%get_local_cols() nrow_a = a%get_nrows() nztota = a%get_nzeros() - if (.false.) then - select case(sm%variant) + select case(sm%variant) case(amg_poly_lottes_) ! do nothing case(amg_poly_lottes_beta_) @@ -89,7 +88,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if case(amg_poly_new_) - + write(psb_out_unit,*) "Nella fase di build sm%pdegree = ",sm%pdegree if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then !Ok sm%cf_a = amg_d_poly_a_vect(sm%pdegree) @@ -100,15 +99,15 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if - case default + case default info = psb_err_internal_error_ call psb_errpush(info,name,& & a_err='invalid sm%variant') goto 9999 end select - end if + sm%pa => a - if (.not.allocated(sm%sv)) then + if (.not.allocated(sm%sv)) then info = psb_err_internal_error_ call psb_errpush(info,name,& & a_err='unallocated sm%sv') @@ -121,7 +120,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if -!!$ if (.false.) then +!!$ if (.false.) then !!$ select type(ssv => sm%sv) !!$ class is(amg_s_l1_diag_solver_type) !!$ da = a%arwsum(info) @@ -129,7 +128,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) !!$ 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 +!!$ sm%rho_ba = sone !!$ end select !!$ else if (sm%rho_ba <= szero) then @@ -153,9 +152,9 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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_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} + 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 diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 index 1e94ec40..89ba79ab 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! 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_descr(sm,info,iout,coarse,prefix) use psb_base_mod @@ -59,13 +59,13 @@ subroutine amg_s_poly_smoother_descr(sm,info,iout,coarse,prefix) call psb_erractionsave(err_act) info = psb_success_ - if (present(coarse)) then + if (present(coarse)) then coarse_ = coarse else coarse_ = .false. end if - if (present(iout)) then - iout_ = iout + if (present(iout)) then + iout_ = iout else iout_ = psb_out_unit endif @@ -78,19 +78,19 @@ subroutine amg_s_poly_smoother_descr(sm,info,iout,coarse,prefix) 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_), ' 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_), ' 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) + 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_), ' Degree: ',sm%pdegree write(iout_,*) trim(prefix_), ' rho_ba: ',sm%rho_ba - !write(iout_,*) trim(prefix_), ' Coefficient: ',sm%cf_a + write(iout_,*) trim(prefix_), ' Coefficient: ',sm%cf_a case default write(iout_,*) trim(prefix_), ' variant: ','UNKNOWN???' end select From 12478a2fff811ac71d725a1a1eae6ab7037c6981 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 21 Feb 2024 16:45:53 +0100 Subject: [PATCH 19/51] Define COARSE_INVFILL --- amgprec/impl/amg_ccprecset.F90 | 14 ++++++++++++++ amgprec/impl/amg_dcprecset.F90 | 14 ++++++++++++++ amgprec/impl/amg_scprecset.F90 | 14 ++++++++++++++ amgprec/impl/amg_zcprecset.F90 | 14 ++++++++++++++ 4 files changed, 56 insertions(+) diff --git a/amgprec/impl/amg_ccprecset.F90 b/amgprec/impl/amg_ccprecset.F90 index 4e7c7c4e..c48dfd85 100644 --- a/amgprec/impl/amg_ccprecset.F90 +++ b/amgprec/impl/amg_ccprecset.F90 @@ -194,6 +194,15 @@ subroutine amg_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) end if call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case('COARSE_INVFILL') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos) + case('BJAC_ITRACE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -243,6 +252,11 @@ subroutine amg_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case('COARSE_INVFILL') + if (nlev_ > 1) then + call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos) + end if + case('BJAC_ITRACE') if (nlev_ > 1) then call p%precv(nlev_)%set('SMOOTHER_ITRACE',val,info,pos=pos) diff --git a/amgprec/impl/amg_dcprecset.F90 b/amgprec/impl/amg_dcprecset.F90 index 83589e17..c7ff4069 100644 --- a/amgprec/impl/amg_dcprecset.F90 +++ b/amgprec/impl/amg_dcprecset.F90 @@ -200,6 +200,15 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) end if call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case('COARSE_INVFILL') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos) + case('BJAC_ITRACE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -249,6 +258,11 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case('COARSE_INVFILL') + if (nlev_ > 1) then + call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos) + end if + case('BJAC_ITRACE') if (nlev_ > 1) then call p%precv(nlev_)%set('SMOOTHER_ITRACE',val,info,pos=pos) diff --git a/amgprec/impl/amg_scprecset.F90 b/amgprec/impl/amg_scprecset.F90 index 741325fb..151b29cc 100644 --- a/amgprec/impl/amg_scprecset.F90 +++ b/amgprec/impl/amg_scprecset.F90 @@ -194,6 +194,15 @@ subroutine amg_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) end if call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case('COARSE_INVFILL') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos) + case('BJAC_ITRACE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -243,6 +252,11 @@ subroutine amg_scprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case('COARSE_INVFILL') + if (nlev_ > 1) then + call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos) + end if + case('BJAC_ITRACE') if (nlev_ > 1) then call p%precv(nlev_)%set('SMOOTHER_ITRACE',val,info,pos=pos) diff --git a/amgprec/impl/amg_zcprecset.F90 b/amgprec/impl/amg_zcprecset.F90 index 3b63befd..37c67df2 100644 --- a/amgprec/impl/amg_zcprecset.F90 +++ b/amgprec/impl/amg_zcprecset.F90 @@ -200,6 +200,15 @@ subroutine amg_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) end if call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case('COARSE_INVFILL') + if (ilev_ /= nlev_) then + write(psb_err_unit,*) name,& + & ': Error: Inconsistent specification of WHAT vs. ILEV' + info = -2 + return + end if + call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos) + case('BJAC_ITRACE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -249,6 +258,11 @@ subroutine amg_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx) call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case('COARSE_INVFILL') + if (nlev_ > 1) then + call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos) + end if + case('BJAC_ITRACE') if (nlev_ > 1) then call p%precv(nlev_)%set('SMOOTHER_ITRACE',val,info,pos=pos) From 7c48b96936894eed7d152ef4821fb4ae350b3ca9 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 21 Feb 2024 16:45:59 +0100 Subject: [PATCH 20/51] Work version of polynomial smoother --- .../amg_d_poly_smoother_apply_vect.f90 | 265 ++++++++++++++++-- .../impl/smoother/amg_d_poly_smoother_bld.f90 | 64 ++--- .../smoother/amg_d_poly_smoother_descr.f90 | 30 +- .../amg_s_poly_smoother_apply_vect.f90 | 265 ++++++++++++++++-- .../impl/smoother/amg_s_poly_smoother_bld.f90 | 64 ++--- .../smoother/amg_s_poly_smoother_descr.f90 | 30 +- 6 files changed, 572 insertions(+), 146 deletions(-) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index 358636d8..662f1c1d 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -49,7 +49,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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 + 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 @@ -121,13 +121,13 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(done,x,dzero,r,desc_data,info) call tx%zero() call ty%zero() - call tz%zero() + call tz%zero() select case(sm%variant) case(amg_poly_lottes_) - block + block real(psb_dpk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! do i=1, sm%pdegree @@ -135,27 +135,31 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*done-3)/(2*i*done+done) cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(done,tz,done,tx,desc_data,info) + if (.false.) then + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(done,tz,done,tx,desc_data,info) + else + call psb_abgdxyz(cr,cz,done,done,ty,tz,tx,desc_data,info) + end if if (.false.) then call psb_geaxpby(done,x,dzero,r,desc_data,info) call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) else call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother LOTTES ',i,res +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother LOTTES',i,res ! x_k = x_{k-1} + z_k end do end block case(amg_poly_lottes_beta_) - block + block real(psb_dpk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! if (allocated(sm%poly_beta)) then @@ -171,29 +175,33 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*done-3)/(2*i*done+done) cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(sm%poly_beta(i),tz,done,tx,desc_data,info) + if (.false.) then + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(sm%poly_beta(i),tz,done,tx,desc_data,info) + else + call psb_abgdxyz(cr,cz,sm%poly_beta(i),done,ty,tz,tx,desc_data,info) + end if if (.false.) then call psb_geaxpby(done,x,dzero,r,desc_data,info) call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) else call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother LOTTES_BETA ',i,res +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother LOTTES_BETA',i,res ! x_k = x_{k-1} + z_k end do end block case(amg_poly_new_) - block + block real(psb_dpk_) :: sigma, theta, delta, rho_old, rho - ! b == x + ! b == x ! x == tx ! - + sm%cf_a = amg_d_poly_a_vect(sm%pdegree) theta = (done+sm%cf_a)/2 delta = (done-sm%cf_a)/2 @@ -201,12 +209,17 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& rho_old = done/sigma call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') call psb_geaxpby((done/sm%rho_ba),ty,dzero,r,desc_data,info) - call psb_geaxpby((done/theta),r,dzero,tz,desc_data,info) + if (.false.) then + call psb_geaxpby((done/theta),r,dzero,tz,desc_data,info) + call psb_geaxpby(done,tz,done,tx,desc_data,info) + else + call psb_abgdxyz((done/theta),dzero,done,done,r,tz,tx,desc_data,info) + end if + ! tz == d do i=1, sm%pdegree - ! x_{k+1} = x_k + d_k - call psb_geaxpby(done,tz,done,tx,desc_data,info) ! + ! ! r_{k-1} = r_k - (1/rho(BA)) B A d_k call psb_spmm(done,sm%pa,tz,dzero,ty,desc_data,info,work=aux,trans=trans_) call sm%sv%apply(-done,ty,done,r,desc_data,trans_,aux,wv(5:),info,init='Z') @@ -214,9 +227,14 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! ! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1} rho = done/(2*sigma - rho_old) - call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) + if (.false.) then + call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) + call psb_geaxpby(done,tz,done,tx,desc_data,info) + else + call psb_abgdxyz((2*rho/delta),(rho*rho_old),done,done,r,tz,tx,desc_data,info) + end if !!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother NEW ',i,res +!!$ write(0,*) 'Polynomial smoother ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -239,10 +257,205 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate + + + +!!$ if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then +!!$ ! if .not.sv%is_iterative, there's no need to pass init +!!$ call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,& +!!$ & name,a_err='Error in sub_aply Jacobi Sweeps = 1') +!!$ goto 9999 +!!$ endif +!!$ +!!$ else if (sweeps >= 0) then +!!$ select type (smsv => sm%sv) +!!$ class is (amg_d_diag_solver_type) +!!$ ! +!!$ ! This means we are dealing with a pure Jacobi smoother/solver. +!!$ ! +!!$ associate(tx => wv(1), ty => wv(2)) +!!$ select case (init_) +!!$ case('Z') +!!$ +!!$ call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') +!!$ +!!$ case('Y') +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_geaxpby(done,y,dzero,ty,desc_data,info) +!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case('U') +!!$ if (.not.present(initu)) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='missing initu to smoother_apply') +!!$ goto 9999 +!!$ end if +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_geaxpby(done,initu,dzero,ty,desc_data,info) +!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case default +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='wrong init to smoother_apply') +!!$ goto 9999 +!!$ end select +!!$ +!!$ do i=1, sweeps-1 +!!$ ! +!!$ ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), +!!$ ! where is the diagonal and A the matrix. +!!$ ! +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ +!!$ if (info /= psb_success_) exit +!!$ +!!$ call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ 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_spmm(-done,sm%pa,ty,done,r,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ if( sm%printres ) then +!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) +!!$ end if +!!$ if ( res < sm%tol*resdenum ) then +!!$ if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & +!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) +!!$ exit +!!$ end if +!!$ end if +!!$ +!!$ end do +!!$ +!!$ +!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='subsolve with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ +!!$ end associate +!!$ +!!$ class default +!!$ ! +!!$ ! +!!$ ! Apply multiple sweeps of a block-Jacobi solver +!!$ ! to compute an approximate solution of a linear system. +!!$ ! +!!$ ! +!!$ if (size(wv) < 2) 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)) +!!$ +!!$ ! +!!$ ! Unroll the first iteration and fold it inside SELECT CASE +!!$ ! this will save one AXPBY and one SPMM when INIT=Z, and will be +!!$ ! significant when sweeps=1 (a common case) +!!$ ! +!!$ select case (init_) +!!$ case('Z') +!!$ +!!$ call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') +!!$ +!!$ case('Y') +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_geaxpby(done,y,dzero,ty,desc_data,info) +!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case('U') +!!$ if (.not.present(initu)) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='missing initu to smoother_apply') +!!$ goto 9999 +!!$ end if +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_geaxpby(done,initu,dzero,ty,desc_data,info) +!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case default +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='wrong init to smoother_apply') +!!$ goto 9999 +!!$ end select +!!$ +!!$ do i=1, sweeps-1 +!!$ ! +!!$ ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the +!!$ ! block diagonal part and the remaining part of the local matrix +!!$ ! and Y(j) is the approximate solution at sweep j. +!!$ ! +!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) +!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) +!!$ +!!$ if (info /= psb_success_) exit +!!$ +!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ 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_spmm(-done,sm%pa,ty,done,r,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ if( sm%printres ) then +!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) +!!$ end if +!!$ if (res < sm%tol*resdenum ) then +!!$ if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & +!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) +!!$ exit +!!$ end if +!!$ end if +!!$ +!!$ end do +!!$ +!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='subsolve with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ end associate +!!$ end select +!!$ +!!$ else +!!$ +!!$ info = psb_err_iarg_neg_ +!!$ call psb_errpush(info,name,& +!!$ & i_err=(/itwo,sweeps,izero,izero,izero/)) +!!$ goto 9999 +!!$ +!!$ endif +!!$ if (.not.(4*n_col <= size(work))) then deallocate(aux) endif +!!$ if(sm%checkres) then +!!$ call psb_gefree(r,desc_data,info) +!!$ end if + call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index 8408beff..ac3f1010 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -56,7 +56,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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(:) + 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 @@ -75,39 +75,39 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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_) - write(psb_out_unit,*) "Nella fase di build sm%pdegree = ",sm%pdegree - 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(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_) - case default + 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%variant') + & a_err='invalid sm%degree for poly_a') goto 9999 - end select + 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 + if (.not.allocated(sm%sv)) then info = psb_err_internal_error_ call psb_errpush(info,name,& & a_err='unallocated sm%sv') @@ -120,7 +120,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if -!!$ if (.false.) then +!!$ if (.false.) then !!$ select type(ssv => sm%sv) !!$ class is(amg_d_l1_diag_solver_type) !!$ da = a%arwsum(info) @@ -128,7 +128,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) !!$ 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 +!!$ sm%rho_ba = done !!$ end select !!$ else if (sm%rho_ba <= dzero) then @@ -152,9 +152,9 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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_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} + 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 index 469e1bb6..9e4803d4 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) use psb_base_mod @@ -59,13 +59,13 @@ subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) call psb_erractionsave(err_act) info = psb_success_ - if (present(coarse)) then + if (present(coarse)) then coarse_ = coarse else coarse_ = .false. end if - if (present(iout)) then - iout_ = iout + if (present(iout)) then + iout_ = iout else iout_ = psb_out_unit endif diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 index b2b7b7df..c76621a9 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 @@ -49,7 +49,7 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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 + 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 @@ -121,13 +121,13 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(sone,x,szero,r,desc_data,info) call tx%zero() call ty%zero() - call tz%zero() + call tz%zero() select case(sm%variant) case(amg_poly_lottes_) - block + block real(psb_spk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! do i=1, sm%pdegree @@ -135,27 +135,31 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*sone-3)/(2*i*sone+sone) cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba) - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(sone,tz,sone,tx,desc_data,info) + if (.false.) then + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(sone,tz,sone,tx,desc_data,info) + else + call psb_abgdxyz(cr,cz,sone,sone,ty,tz,tx,desc_data,info) + end if if (.false.) then call psb_geaxpby(sone,x,szero,r,desc_data,info) call psb_spmm(-sone,sm%pa,tx,sone,r,desc_data,info,work=aux,trans=trans_) else call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_) end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother LOTTES ',i,res +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother LOTTES',i,res ! x_k = x_{k-1} + z_k end do end block case(amg_poly_lottes_beta_) - block + block real(psb_spk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! if (allocated(sm%poly_beta)) then @@ -171,29 +175,33 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*sone-3)/(2*i*sone+sone) cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba) - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(sm%poly_beta(i),tz,sone,tx,desc_data,info) + if (.false.) then + ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} + call psb_geaxpby(cr,ty,cz,tz,desc_data,info) + ! r_k = b-Ax_k = x -A tx + call psb_geaxpby(sm%poly_beta(i),tz,sone,tx,desc_data,info) + else + call psb_abgdxyz(cr,cz,sm%poly_beta(i),sone,ty,tz,tx,desc_data,info) + end if if (.false.) then call psb_geaxpby(sone,x,szero,r,desc_data,info) call psb_spmm(-sone,sm%pa,tx,sone,r,desc_data,info,work=aux,trans=trans_) else call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_) end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother LOTTES_BETA ',i,res +!!$ res = psb_genrm2(r,desc_data,info) +!!$ write(0,*) 'Polynomial smoother LOTTES_BETA',i,res ! x_k = x_{k-1} + z_k end do end block case(amg_poly_new_) - block + block real(psb_spk_) :: sigma, theta, delta, rho_old, rho - ! b == x + ! b == x ! x == tx ! - + sm%cf_a = amg_d_poly_a_vect(sm%pdegree) theta = (sone+sm%cf_a)/2 delta = (sone-sm%cf_a)/2 @@ -201,12 +209,17 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& rho_old = sone/sigma call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') call psb_geaxpby((sone/sm%rho_ba),ty,szero,r,desc_data,info) - call psb_geaxpby((sone/theta),r,szero,tz,desc_data,info) + if (.false.) then + call psb_geaxpby((sone/theta),r,szero,tz,desc_data,info) + call psb_geaxpby(sone,tz,sone,tx,desc_data,info) + else + call psb_abgdxyz((sone/theta),szero,sone,sone,r,tz,tx,desc_data,info) + end if + ! tz == d do i=1, sm%pdegree - ! x_{k+1} = x_k + d_k - call psb_geaxpby(sone,tz,sone,tx,desc_data,info) ! + ! ! r_{k-1} = r_k - (1/rho(BA)) B A d_k call psb_spmm(sone,sm%pa,tz,szero,ty,desc_data,info,work=aux,trans=trans_) call sm%sv%apply(-sone,ty,sone,r,desc_data,trans_,aux,wv(5:),info,init='Z') @@ -214,9 +227,14 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! ! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1} rho = sone/(2*sigma - rho_old) - call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) + if (.false.) then + call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) + call psb_geaxpby(sone,tz,sone,tx,desc_data,info) + else + call psb_abgdxyz((2*rho/delta),(rho*rho_old),sone,sone,r,tz,tx,desc_data,info) + end if !!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother NEW ',i,res +!!$ write(0,*) 'Polynomial smoother ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -239,10 +257,205 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate + + + +!!$ if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then +!!$ ! if .not.sv%is_iterative, there's no need to pass init +!!$ call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,& +!!$ & name,a_err='Error in sub_aply Jacobi Sweeps = 1') +!!$ goto 9999 +!!$ endif +!!$ +!!$ else if (sweeps >= 0) then +!!$ select type (smsv => sm%sv) +!!$ class is (amg_s_diag_solver_type) +!!$ ! +!!$ ! This means we are dealing with a pure Jacobi smoother/solver. +!!$ ! +!!$ associate(tx => wv(1), ty => wv(2)) +!!$ select case (init_) +!!$ case('Z') +!!$ +!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') +!!$ +!!$ case('Y') +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info) +!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case('U') +!!$ if (.not.present(initu)) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='missing initu to smoother_apply') +!!$ goto 9999 +!!$ end if +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info) +!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case default +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='wrong init to smoother_apply') +!!$ goto 9999 +!!$ end select +!!$ +!!$ do i=1, sweeps-1 +!!$ ! +!!$ ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), +!!$ ! where is the diagonal and A the matrix. +!!$ ! +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ +!!$ if (info /= psb_success_) exit +!!$ +!!$ call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ 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_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ if( sm%printres ) then +!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) +!!$ end if +!!$ if ( res < sm%tol*resdenum ) then +!!$ if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & +!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) +!!$ exit +!!$ end if +!!$ end if +!!$ +!!$ end do +!!$ +!!$ +!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='subsolve with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ +!!$ end associate +!!$ +!!$ class default +!!$ ! +!!$ ! +!!$ ! Apply multiple sweeps of a block-Jacobi solver +!!$ ! to compute an approximate solution of a linear system. +!!$ ! +!!$ ! +!!$ if (size(wv) < 2) 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)) +!!$ +!!$ ! +!!$ ! Unroll the first iteration and fold it inside SELECT CASE +!!$ ! this will save one AXPBY and one SPMM when INIT=Z, and will be +!!$ ! significant when sweeps=1 (a common case) +!!$ ! +!!$ select case (init_) +!!$ case('Z') +!!$ +!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') +!!$ +!!$ case('Y') +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info) +!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case('U') +!!$ if (.not.present(initu)) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='missing initu to smoother_apply') +!!$ goto 9999 +!!$ end if +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info) +!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ case default +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='wrong init to smoother_apply') +!!$ goto 9999 +!!$ end select +!!$ +!!$ do i=1, sweeps-1 +!!$ ! +!!$ ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the +!!$ ! block diagonal part and the remaining part of the local matrix +!!$ ! and Y(j) is the approximate solution at sweep j. +!!$ ! +!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) +!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) +!!$ +!!$ if (info /= psb_success_) exit +!!$ +!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') +!!$ +!!$ 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_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) +!!$ res = psb_genrm2(r,desc_data,info) +!!$ if( sm%printres ) then +!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) +!!$ end if +!!$ if (res < sm%tol*resdenum ) then +!!$ if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & +!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) +!!$ exit +!!$ end if +!!$ end if +!!$ +!!$ end do +!!$ +!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='subsolve with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ end associate +!!$ end select +!!$ +!!$ else +!!$ +!!$ info = psb_err_iarg_neg_ +!!$ call psb_errpush(info,name,& +!!$ & i_err=(/itwo,sweeps,izero,izero,izero/)) +!!$ goto 9999 +!!$ +!!$ endif +!!$ if (.not.(4*n_col <= size(work))) then deallocate(aux) endif +!!$ if(sm%checkres) then +!!$ call psb_gefree(r,desc_data,info) +!!$ end if + call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 index 3b0f5846..44df090f 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 @@ -56,7 +56,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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(:) + 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 @@ -75,39 +75,39 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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_) - write(psb_out_unit,*) "Nella fase di build sm%pdegree = ",sm%pdegree - 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(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_) - case default + 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%variant') + & a_err='invalid sm%degree for poly_a') goto 9999 - end select + 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 + if (.not.allocated(sm%sv)) then info = psb_err_internal_error_ call psb_errpush(info,name,& & a_err='unallocated sm%sv') @@ -120,7 +120,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if -!!$ if (.false.) then +!!$ if (.false.) then !!$ select type(ssv => sm%sv) !!$ class is(amg_s_l1_diag_solver_type) !!$ da = a%arwsum(info) @@ -128,7 +128,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) !!$ 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 +!!$ sm%rho_ba = sone !!$ end select !!$ else if (sm%rho_ba <= szero) then @@ -152,9 +152,9 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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_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} + 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 diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 index 89ba79ab..86152eb9 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! 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_descr(sm,info,iout,coarse,prefix) use psb_base_mod @@ -59,13 +59,13 @@ subroutine amg_s_poly_smoother_descr(sm,info,iout,coarse,prefix) call psb_erractionsave(err_act) info = psb_success_ - if (present(coarse)) then + if (present(coarse)) then coarse_ = coarse else coarse_ = .false. end if - if (present(iout)) then - iout_ = iout + if (present(iout)) then + iout_ = iout else iout_ = psb_out_unit endif From 4e6e3d5f0941ab38d77752f4f9f44ef238ee2b26 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 21 Feb 2024 16:50:55 +0100 Subject: [PATCH 21/51] Fix merge conflict --- .../amg_d_poly_smoother_apply_vect.f90 | 211 +----------------- .../impl/smoother/amg_d_poly_smoother_bld.f90 | 12 +- .../smoother/amg_d_poly_smoother_descr.f90 | 30 +-- .../amg_s_poly_smoother_apply_vect.f90 | 211 +----------------- .../impl/smoother/amg_s_poly_smoother_bld.f90 | 12 +- .../smoother/amg_s_poly_smoother_descr.f90 | 30 +-- 6 files changed, 58 insertions(+), 448 deletions(-) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index 662f1c1d..9d348bc5 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -121,13 +121,13 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(done,x,dzero,r,desc_data,info) call tx%zero() call ty%zero() - call tz%zero() + call tz%zero() select case(sm%variant) case(amg_poly_lottes_) - block + block real(psb_dpk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! do i=1, sm%pdegree @@ -157,9 +157,9 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& case(amg_poly_lottes_beta_) - block + block real(psb_dpk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! if (allocated(sm%poly_beta)) then @@ -196,9 +196,9 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end block case(amg_poly_new_) - block + block real(psb_dpk_) :: sigma, theta, delta, rho_old, rho - ! b == x + ! b == x ! x == tx ! sm%cf_a = amg_d_poly_a_vect(sm%pdegree) @@ -234,7 +234,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_abgdxyz((2*rho/delta),(rho*rho_old),done,done,r,tz,tx,desc_data,info) end if !!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother ',i,res +!!$ write(0,*) 'Polynomial smoother NEW ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -257,205 +257,10 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate - - - -!!$ if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then -!!$ ! if .not.sv%is_iterative, there's no need to pass init -!!$ call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_internal_error_,& -!!$ & name,a_err='Error in sub_aply Jacobi Sweeps = 1') -!!$ goto 9999 -!!$ endif -!!$ -!!$ else if (sweeps >= 0) then -!!$ select type (smsv => sm%sv) -!!$ class is (amg_d_diag_solver_type) -!!$ ! -!!$ ! This means we are dealing with a pure Jacobi smoother/solver. -!!$ ! -!!$ associate(tx => wv(1), ty => wv(2)) -!!$ select case (init_) -!!$ case('Z') -!!$ -!!$ call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') -!!$ -!!$ case('Y') -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_geaxpby(done,y,dzero,ty,desc_data,info) -!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case('U') -!!$ if (.not.present(initu)) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='missing initu to smoother_apply') -!!$ goto 9999 -!!$ end if -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_geaxpby(done,initu,dzero,ty,desc_data,info) -!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case default -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='wrong init to smoother_apply') -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, sweeps-1 -!!$ ! -!!$ ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), -!!$ ! where is the diagonal and A the matrix. -!!$ ! -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ -!!$ if (info /= psb_success_) exit -!!$ -!!$ call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ 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_spmm(-done,sm%pa,ty,done,r,desc_data,info) -!!$ res = psb_genrm2(r,desc_data,info) -!!$ if( sm%printres ) then -!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) -!!$ end if -!!$ if ( res < sm%tol*resdenum ) then -!!$ if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & -!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) -!!$ exit -!!$ end if -!!$ end if -!!$ -!!$ end do -!!$ -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='subsolve with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ end associate -!!$ -!!$ class default -!!$ ! -!!$ ! -!!$ ! Apply multiple sweeps of a block-Jacobi solver -!!$ ! to compute an approximate solution of a linear system. -!!$ ! -!!$ ! -!!$ if (size(wv) < 2) 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)) -!!$ -!!$ ! -!!$ ! Unroll the first iteration and fold it inside SELECT CASE -!!$ ! this will save one AXPBY and one SPMM when INIT=Z, and will be -!!$ ! significant when sweeps=1 (a common case) -!!$ ! -!!$ select case (init_) -!!$ case('Z') -!!$ -!!$ call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') -!!$ -!!$ case('Y') -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_geaxpby(done,y,dzero,ty,desc_data,info) -!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case('U') -!!$ if (.not.present(initu)) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='missing initu to smoother_apply') -!!$ goto 9999 -!!$ end if -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_geaxpby(done,initu,dzero,ty,desc_data,info) -!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case default -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='wrong init to smoother_apply') -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, sweeps-1 -!!$ ! -!!$ ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the -!!$ ! block diagonal part and the remaining part of the local matrix -!!$ ! and Y(j) is the approximate solution at sweep j. -!!$ ! -!!$ call psb_geaxpby(done,x,dzero,tx,desc_data,info) -!!$ call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) -!!$ -!!$ if (info /= psb_success_) exit -!!$ -!!$ call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ 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_spmm(-done,sm%pa,ty,done,r,desc_data,info) -!!$ res = psb_genrm2(r,desc_data,info) -!!$ if( sm%printres ) then -!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) -!!$ end if -!!$ if (res < sm%tol*resdenum ) then -!!$ if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & -!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) -!!$ exit -!!$ end if -!!$ end if -!!$ -!!$ end do -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='subsolve with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if -!!$ -!!$ end associate -!!$ end select -!!$ -!!$ else -!!$ -!!$ info = psb_err_iarg_neg_ -!!$ call psb_errpush(info,name,& -!!$ & i_err=(/itwo,sweeps,izero,izero,izero/)) -!!$ goto 9999 -!!$ -!!$ endif -!!$ if (.not.(4*n_col <= size(work))) then deallocate(aux) endif -!!$ if(sm%checkres) then -!!$ call psb_gefree(r,desc_data,info) -!!$ end if - call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index ac3f1010..dd156912 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -56,7 +56,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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(:) + 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 @@ -107,7 +107,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) end select sm%pa => a - if (.not.allocated(sm%sv)) then + if (.not.allocated(sm%sv)) then info = psb_err_internal_error_ call psb_errpush(info,name,& & a_err='unallocated sm%sv') @@ -120,7 +120,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if -!!$ if (.false.) then +!!$ if (.false.) then !!$ select type(ssv => sm%sv) !!$ class is(amg_d_l1_diag_solver_type) !!$ da = a%arwsum(info) @@ -128,7 +128,7 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) !!$ 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 +!!$ sm%rho_ba = done !!$ end select !!$ else if (sm%rho_ba <= dzero) then @@ -152,9 +152,9 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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_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} + 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 diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 index 9e4803d4..469e1bb6 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_descr.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) use psb_base_mod @@ -59,13 +59,13 @@ subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix) call psb_erractionsave(err_act) info = psb_success_ - if (present(coarse)) then + if (present(coarse)) then coarse_ = coarse else coarse_ = .false. end if - if (present(iout)) then - iout_ = iout + if (present(iout)) then + iout_ = iout else iout_ = psb_out_unit endif diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 index c76621a9..53c2cb43 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 @@ -121,13 +121,13 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(sone,x,szero,r,desc_data,info) call tx%zero() call ty%zero() - call tz%zero() + call tz%zero() select case(sm%variant) case(amg_poly_lottes_) - block + block real(psb_spk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! do i=1, sm%pdegree @@ -157,9 +157,9 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& case(amg_poly_lottes_beta_) - block + block real(psb_spk_) :: cz, cr - ! b == x + ! b == x ! x == tx ! if (allocated(sm%poly_beta)) then @@ -196,9 +196,9 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end block case(amg_poly_new_) - block + block real(psb_spk_) :: sigma, theta, delta, rho_old, rho - ! b == x + ! b == x ! x == tx ! sm%cf_a = amg_d_poly_a_vect(sm%pdegree) @@ -234,7 +234,7 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_abgdxyz((2*rho/delta),(rho*rho_old),sone,sone,r,tz,tx,desc_data,info) end if !!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother ',i,res +!!$ write(0,*) 'Polynomial smoother NEW ',i,res ! x_k = x_{k-1} + z_k end do end block @@ -257,205 +257,10 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if end associate - - - -!!$ if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then -!!$ ! if .not.sv%is_iterative, there's no need to pass init -!!$ call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_internal_error_,& -!!$ & name,a_err='Error in sub_aply Jacobi Sweeps = 1') -!!$ goto 9999 -!!$ endif -!!$ -!!$ else if (sweeps >= 0) then -!!$ select type (smsv => sm%sv) -!!$ class is (amg_s_diag_solver_type) -!!$ ! -!!$ ! This means we are dealing with a pure Jacobi smoother/solver. -!!$ ! -!!$ associate(tx => wv(1), ty => wv(2)) -!!$ select case (init_) -!!$ case('Z') -!!$ -!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') -!!$ -!!$ case('Y') -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info) -!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case('U') -!!$ if (.not.present(initu)) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='missing initu to smoother_apply') -!!$ goto 9999 -!!$ end if -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info) -!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case default -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='wrong init to smoother_apply') -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, sweeps-1 -!!$ ! -!!$ ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)), -!!$ ! where is the diagonal and A the matrix. -!!$ ! -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ -!!$ if (info /= psb_success_) exit -!!$ -!!$ call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ 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_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) -!!$ res = psb_genrm2(r,desc_data,info) -!!$ if( sm%printres ) then -!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) -!!$ end if -!!$ if ( res < sm%tol*resdenum ) then -!!$ if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) & -!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) -!!$ exit -!!$ end if -!!$ end if -!!$ -!!$ end do -!!$ -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='subsolve with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ end associate -!!$ -!!$ class default -!!$ ! -!!$ ! -!!$ ! Apply multiple sweeps of a block-Jacobi solver -!!$ ! to compute an approximate solution of a linear system. -!!$ ! -!!$ ! -!!$ if (size(wv) < 2) 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)) -!!$ -!!$ ! -!!$ ! Unroll the first iteration and fold it inside SELECT CASE -!!$ ! this will save one AXPBY and one SPMM when INIT=Z, and will be -!!$ ! significant when sweeps=1 (a common case) -!!$ ! -!!$ select case (init_) -!!$ case('Z') -!!$ -!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') -!!$ -!!$ case('Y') -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info) -!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case('U') -!!$ if (.not.present(initu)) then -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='missing initu to smoother_apply') -!!$ goto 9999 -!!$ end if -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info) -!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ case default -!!$ call psb_errpush(psb_err_internal_error_,name,& -!!$ & a_err='wrong init to smoother_apply') -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, sweeps-1 -!!$ ! -!!$ ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the -!!$ ! block diagonal part and the remaining part of the local matrix -!!$ ! and Y(j) is the approximate solution at sweep j. -!!$ ! -!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info) -!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) -!!$ -!!$ if (info /= psb_success_) exit -!!$ -!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') -!!$ -!!$ 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_spmm(-sone,sm%pa,ty,sone,r,desc_data,info) -!!$ res = psb_genrm2(r,desc_data,info) -!!$ if( sm%printres ) then -!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol) -!!$ end if -!!$ if (res < sm%tol*resdenum ) then -!!$ if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) & -!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol) -!!$ exit -!!$ end if -!!$ end if -!!$ -!!$ end do -!!$ -!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='subsolve with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if -!!$ -!!$ end associate -!!$ end select -!!$ -!!$ else -!!$ -!!$ info = psb_err_iarg_neg_ -!!$ call psb_errpush(info,name,& -!!$ & i_err=(/itwo,sweeps,izero,izero,izero/)) -!!$ goto 9999 -!!$ -!!$ endif -!!$ if (.not.(4*n_col <= size(work))) then deallocate(aux) endif -!!$ if(sm%checkres) then -!!$ call psb_gefree(r,desc_data,info) -!!$ end if - call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 index 44df090f..09b01248 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_bld.f90 @@ -56,7 +56,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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(:) + 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 @@ -107,7 +107,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) end select sm%pa => a - if (.not.allocated(sm%sv)) then + if (.not.allocated(sm%sv)) then info = psb_err_internal_error_ call psb_errpush(info,name,& & a_err='unallocated sm%sv') @@ -120,7 +120,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) goto 9999 end if -!!$ if (.false.) then +!!$ if (.false.) then !!$ select type(ssv => sm%sv) !!$ class is(amg_s_l1_diag_solver_type) !!$ da = a%arwsum(info) @@ -128,7 +128,7 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) !!$ 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 +!!$ sm%rho_ba = sone !!$ end select !!$ else if (sm%rho_ba <= szero) then @@ -152,9 +152,9 @@ subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) 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_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} + 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 diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 index 86152eb9..89ba79ab 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_descr.f90 @@ -1,15 +1,15 @@ -! -! +! +! ! 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 -! +! +! (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: @@ -21,7 +21,7 @@ ! 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 @@ -33,8 +33,8 @@ ! 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_descr(sm,info,iout,coarse,prefix) use psb_base_mod @@ -59,13 +59,13 @@ subroutine amg_s_poly_smoother_descr(sm,info,iout,coarse,prefix) call psb_erractionsave(err_act) info = psb_success_ - if (present(coarse)) then + if (present(coarse)) then coarse_ = coarse else coarse_ = .false. end if - if (present(iout)) then - iout_ = iout + if (present(iout)) then + iout_ = iout else iout_ = psb_out_unit endif From d385d99e714b892229329e37cbcaa774ae45980e Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Tue, 5 Mar 2024 18:43:34 +0100 Subject: [PATCH 22/51] Fixed Cheby1 Implementation --- .../smoother/amg_d_poly_smoother_apply_vect.f90 | 16 ++++++++-------- .../smoother/amg_s_poly_smoother_apply_vect.f90 | 16 ++++++++-------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index 9d348bc5..32926bd6 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -135,7 +135,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*done-3)/(2*i*done+done) cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) - if (.false.) then + if (.false.) then ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} call psb_geaxpby(cr,ty,cz,tz,desc_data,info) ! r_k = b-Ax_k = x -A tx @@ -175,7 +175,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*done-3)/(2*i*done+done) cr = (8*i*done-4)/((2*i*done+done)*sm%rho_ba) - if (.false.) then + if (.false.) then ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} call psb_geaxpby(cr,ty,cz,tz,desc_data,info) ! r_k = b-Ax_k = x -A tx @@ -201,7 +201,6 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! b == x ! x == tx ! - sm%cf_a = amg_d_poly_a_vect(sm%pdegree) theta = (done+sm%cf_a)/2 delta = (done-sm%cf_a)/2 @@ -209,25 +208,25 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& rho_old = done/sigma call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') call psb_geaxpby((done/sm%rho_ba),ty,dzero,r,desc_data,info) - if (.false.) then + if (.false.) then call psb_geaxpby((done/theta),r,dzero,tz,desc_data,info) call psb_geaxpby(done,tz,done,tx,desc_data,info) else call psb_abgdxyz((done/theta),dzero,done,done,r,tz,tx,desc_data,info) end if - + ! tz == d - do i=1, sm%pdegree + do i=1, sm%pdegree-1 ! ! ! r_{k-1} = r_k - (1/rho(BA)) B A d_k call psb_spmm(done,sm%pa,tz,dzero,ty,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(-done,ty,done,r,desc_data,trans_,aux,wv(5:),info,init='Z') + call sm%sv%apply(-(done/sm%rho_ba),ty,done,r,desc_data,trans_,aux,wv(5:),info,init='Z') ! ! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1} rho = done/(2*sigma - rho_old) - if (.false.) then + if (.false.) then call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) call psb_geaxpby(done,tz,done,tx,desc_data,info) else @@ -236,6 +235,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& !!$ res = psb_genrm2(r,desc_data,info) !!$ write(0,*) 'Polynomial smoother NEW ',i,res ! x_k = x_{k-1} + z_k + rho_old = rho end do end block diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 index 53c2cb43..fca259ff 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 @@ -135,7 +135,7 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*sone-3)/(2*i*sone+sone) cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba) - if (.false.) then + if (.false.) then ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} call psb_geaxpby(cr,ty,cz,tz,desc_data,info) ! r_k = b-Ax_k = x -A tx @@ -175,7 +175,7 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') cz = (2*i*sone-3)/(2*i*sone+sone) cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba) - if (.false.) then + if (.false.) then ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} call psb_geaxpby(cr,ty,cz,tz,desc_data,info) ! r_k = b-Ax_k = x -A tx @@ -201,7 +201,6 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! b == x ! x == tx ! - sm%cf_a = amg_d_poly_a_vect(sm%pdegree) theta = (sone+sm%cf_a)/2 delta = (sone-sm%cf_a)/2 @@ -209,25 +208,25 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& rho_old = sone/sigma call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') call psb_geaxpby((sone/sm%rho_ba),ty,szero,r,desc_data,info) - if (.false.) then + if (.false.) then call psb_geaxpby((sone/theta),r,szero,tz,desc_data,info) call psb_geaxpby(sone,tz,sone,tx,desc_data,info) else call psb_abgdxyz((sone/theta),szero,sone,sone,r,tz,tx,desc_data,info) end if - + ! tz == d - do i=1, sm%pdegree + do i=1, sm%pdegree-1 ! ! ! r_{k-1} = r_k - (1/rho(BA)) B A d_k call psb_spmm(sone,sm%pa,tz,szero,ty,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(-sone,ty,sone,r,desc_data,trans_,aux,wv(5:),info,init='Z') + call sm%sv%apply(-(sone/sm%rho_ba),ty,sone,r,desc_data,trans_,aux,wv(5:),info,init='Z') ! ! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1} rho = sone/(2*sigma - rho_old) - if (.false.) then + if (.false.) then call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) call psb_geaxpby(sone,tz,sone,tx,desc_data,info) else @@ -236,6 +235,7 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& !!$ res = psb_genrm2(r,desc_data,info) !!$ write(0,*) 'Polynomial smoother NEW ',i,res ! x_k = x_{k-1} + z_k + rho_old = rho end do end block From a747cc6abb0bb95891b20dffeeef87c1e1ddfe34 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 15 Mar 2024 15:47:56 +0100 Subject: [PATCH 23/51] Defined memory_use method --- amgprec/amg_c_onelev_mod.f90 | 17 ++ amgprec/amg_c_prec_type.f90 | 16 ++ amgprec/amg_d_onelev_mod.f90 | 17 ++ amgprec/amg_d_prec_type.f90 | 16 ++ amgprec/amg_s_onelev_mod.f90 | 17 ++ amgprec/amg_s_prec_type.f90 | 16 ++ amgprec/amg_z_onelev_mod.f90 | 17 ++ amgprec/amg_z_prec_type.f90 | 16 ++ amgprec/impl/Makefile | 8 +- amgprec/impl/amg_cfile_prec_memory_use.f90 | 149 ++++++++++++++++++ amgprec/impl/amg_dfile_prec_memory_use.f90 | 149 ++++++++++++++++++ amgprec/impl/amg_sfile_prec_memory_use.f90 | 149 ++++++++++++++++++ amgprec/impl/amg_zfile_prec_memory_use.f90 | 149 ++++++++++++++++++ amgprec/impl/level/Makefile | 4 + .../level/amg_c_base_onelev_memory_use.f90 | 113 +++++++++++++ .../level/amg_d_base_onelev_memory_use.f90 | 113 +++++++++++++ .../level/amg_s_base_onelev_memory_use.f90 | 113 +++++++++++++ .../level/amg_z_base_onelev_memory_use.f90 | 113 +++++++++++++ 18 files changed, 1188 insertions(+), 4 deletions(-) create mode 100644 amgprec/impl/amg_cfile_prec_memory_use.f90 create mode 100644 amgprec/impl/amg_dfile_prec_memory_use.f90 create mode 100644 amgprec/impl/amg_sfile_prec_memory_use.f90 create mode 100644 amgprec/impl/amg_zfile_prec_memory_use.f90 create mode 100644 amgprec/impl/level/amg_c_base_onelev_memory_use.f90 create mode 100644 amgprec/impl/level/amg_d_base_onelev_memory_use.f90 create mode 100644 amgprec/impl/level/amg_s_base_onelev_memory_use.f90 create mode 100644 amgprec/impl/level/amg_z_base_onelev_memory_use.f90 diff --git a/amgprec/amg_c_onelev_mod.f90 b/amgprec/amg_c_onelev_mod.f90 index 2cef1397..3a980ff3 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,22 @@ 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) + 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 + 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..1afdad53 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,21 @@ 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) + 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 + 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_onelev_mod.f90 b/amgprec/amg_d_onelev_mod.f90 index 60ed9448..3f21a2a6 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,22 @@ 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) + 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 + 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_prec_type.f90 b/amgprec/amg_d_prec_type.f90 index 9fbc2b5d..90f5a2a8 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,21 @@ 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) + 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 + 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_onelev_mod.f90 b/amgprec/amg_s_onelev_mod.f90 index c826001d..9019c643 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,22 @@ 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) + 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 + 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_prec_type.f90 b/amgprec/amg_s_prec_type.f90 index 88a22078..246e763c 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,21 @@ 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) + 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 + 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_onelev_mod.f90 b/amgprec/amg_z_onelev_mod.f90 index 78259f4d..538ea9fa 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,22 @@ 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) + 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 + 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..1d1addc6 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,21 @@ 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) + 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 + 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/amg_cfile_prec_memory_use.f90 b/amgprec/impl/amg_cfile_prec_memory_use.f90 new file mode 100644 index 00000000..b71cefe2 --- /dev/null +++ b/amgprec/impl/amg_cfile_prec_memory_use.f90 @@ -0,0 +1,149 @@ +! +! +! 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) + 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 + + + ! 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_ + 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 + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + ctxt = prec%ctxt + + if (allocated(prec%precv)) then + + call psb_info(ctxt,me,np) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + end if + if (root_ == -1) root_ = me + + if (verbosity_ >=0) then + ! + ! The preconditioner description is printed by processor psb_root_. + ! This agrees with the fact that all the parameters defining the + ! preconditioner have the same values on all the procs (this is + ! ensured by amg_precbld). + ! + if (me == root_) then + + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + nlev = size(prec%precv) + do ilev=1,nlev + call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & + & iout=iout_,verbosity=verbosity,prefix=prefix) + end do + end if + end if + else + write(iout_,*) trim(name), & + & ': Error: no base preconditioner available, something is wrong!' + info = -2 + return + endif +9998 continue +end subroutine amg_cfile_prec_memory_use 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..9eb63c8b --- /dev/null +++ b/amgprec/impl/amg_dfile_prec_memory_use.f90 @@ -0,0 +1,149 @@ +! +! +! 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) + 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 + + + ! 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_ + 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 + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + ctxt = prec%ctxt + + if (allocated(prec%precv)) then + + call psb_info(ctxt,me,np) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + end if + if (root_ == -1) root_ = me + + if (verbosity_ >=0) then + ! + ! The preconditioner description is printed by processor psb_root_. + ! This agrees with the fact that all the parameters defining the + ! preconditioner have the same values on all the procs (this is + ! ensured by amg_precbld). + ! + if (me == root_) then + + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + nlev = size(prec%precv) + do ilev=1,nlev + call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & + & iout=iout_,verbosity=verbosity,prefix=prefix) + end do + end if + end if + else + write(iout_,*) trim(name), & + & ': Error: no base preconditioner available, something is wrong!' + info = -2 + return + endif +9998 continue +end subroutine amg_dfile_prec_memory_use 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..49373233 --- /dev/null +++ b/amgprec/impl/amg_sfile_prec_memory_use.f90 @@ -0,0 +1,149 @@ +! +! +! 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) + 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 + + + ! 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_ + 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 + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + ctxt = prec%ctxt + + if (allocated(prec%precv)) then + + call psb_info(ctxt,me,np) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + end if + if (root_ == -1) root_ = me + + if (verbosity_ >=0) then + ! + ! The preconditioner description is printed by processor psb_root_. + ! This agrees with the fact that all the parameters defining the + ! preconditioner have the same values on all the procs (this is + ! ensured by amg_precbld). + ! + if (me == root_) then + + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + nlev = size(prec%precv) + do ilev=1,nlev + call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & + & iout=iout_,verbosity=verbosity,prefix=prefix) + end do + end if + end if + else + write(iout_,*) trim(name), & + & ': Error: no base preconditioner available, something is wrong!' + info = -2 + return + endif +9998 continue +end subroutine amg_sfile_prec_memory_use 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..3657e9a5 --- /dev/null +++ b/amgprec/impl/amg_zfile_prec_memory_use.f90 @@ -0,0 +1,149 @@ +! +! +! 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) + 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 + + + ! 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_ + 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 + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + ctxt = prec%ctxt + + if (allocated(prec%precv)) then + + call psb_info(ctxt,me,np) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + end if + if (root_ == -1) root_ = me + + if (verbosity_ >=0) then + ! + ! The preconditioner description is printed by processor psb_root_. + ! This agrees with the fact that all the parameters defining the + ! preconditioner have the same values on all the procs (this is + ! ensured by amg_precbld). + ! + if (me == root_) then + + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + nlev = size(prec%precv) + do ilev=1,nlev + call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & + & iout=iout_,verbosity=verbosity,prefix=prefix) + end do + end if + end if + else + write(iout_,*) trim(name), & + & ': Error: no base preconditioner available, something is wrong!' + info = -2 + return + endif +9998 continue +end subroutine amg_zfile_prec_memory_use 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_memory_use.f90 b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 new file mode 100644 index 00000000..517c3892 --- /dev/null +++ b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 @@ -0,0 +1,113 @@ +! +! +! 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) + + 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 + integer(psb_ipk_), intent(in), optional :: verbosity + character(len=*), intent(in), optional :: prefix + + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_c_base_onelev_memory_use' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse + character(1024) :: prefix_ + + + call psb_erractionsave(err_act) + + + 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(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + write(iout_,*) trim(prefix_) + + 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() + + +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_memory_use.f90 b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 new file mode 100644 index 00000000..d339d3a9 --- /dev/null +++ b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 @@ -0,0 +1,113 @@ +! +! +! 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) + + 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 + integer(psb_ipk_), intent(in), optional :: verbosity + character(len=*), intent(in), optional :: prefix + + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_d_base_onelev_memory_use' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse + character(1024) :: prefix_ + + + call psb_erractionsave(err_act) + + + 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(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + write(iout_,*) trim(prefix_) + + 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() + + +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_memory_use.f90 b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 new file mode 100644 index 00000000..a8c130e6 --- /dev/null +++ b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 @@ -0,0 +1,113 @@ +! +! +! 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) + + 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 + integer(psb_ipk_), intent(in), optional :: verbosity + character(len=*), intent(in), optional :: prefix + + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_s_base_onelev_memory_use' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse + character(1024) :: prefix_ + + + call psb_erractionsave(err_act) + + + 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(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + write(iout_,*) trim(prefix_) + + 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() + + +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_memory_use.f90 b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 new file mode 100644 index 00000000..db73ac0b --- /dev/null +++ b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 @@ -0,0 +1,113 @@ +! +! +! 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) + + 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 + integer(psb_ipk_), intent(in), optional :: verbosity + character(len=*), intent(in), optional :: prefix + + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_z_base_onelev_memory_use' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse + character(1024) :: prefix_ + + + call psb_erractionsave(err_act) + + + 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(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + write(iout_,*) trim(prefix_) + + 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() + + +9998 continue + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine amg_z_base_onelev_memory_use From 3671285c7a402dc578f04c5c3ca8087a16f412a6 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 16 Mar 2024 13:15:35 +0100 Subject: [PATCH 24/51] Modified memory_use impl with GLOBAL and VERBOSITY --- amgprec/amg_c_onelev_mod.f90 | 4 +- amgprec/amg_c_prec_type.f90 | 3 +- amgprec/amg_d_onelev_mod.f90 | 4 +- amgprec/amg_d_prec_type.f90 | 3 +- amgprec/amg_s_onelev_mod.f90 | 4 +- amgprec/amg_s_prec_type.f90 | 3 +- amgprec/amg_z_onelev_mod.f90 | 4 +- amgprec/amg_z_prec_type.f90 | 3 +- amgprec/impl/amg_cfile_prec_memory_use.f90 | 57 +++++++++----- amgprec/impl/amg_dfile_prec_memory_use.f90 | 57 +++++++++----- amgprec/impl/amg_sfile_prec_memory_use.f90 | 57 +++++++++----- amgprec/impl/amg_zfile_prec_memory_use.f90 | 57 +++++++++----- .../level/amg_c_base_onelev_memory_use.f90 | 76 ++++++++++++------- .../level/amg_d_base_onelev_memory_use.f90 | 76 ++++++++++++------- .../level/amg_s_base_onelev_memory_use.f90 | 76 ++++++++++++------- .../level/amg_z_base_onelev_memory_use.f90 | 76 ++++++++++++------- 16 files changed, 364 insertions(+), 196 deletions(-) diff --git a/amgprec/amg_c_onelev_mod.f90 b/amgprec/amg_c_onelev_mod.f90 index 3a980ff3..f5411e45 100644 --- a/amgprec/amg_c_onelev_mod.f90 +++ b/amgprec/amg_c_onelev_mod.f90 @@ -275,7 +275,7 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, verbosity,prefix) + subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, 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 @@ -285,8 +285,8 @@ module amg_c_onelev_mod 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 diff --git a/amgprec/amg_c_prec_type.f90 b/amgprec/amg_c_prec_type.f90 index 1afdad53..2ce58807 100644 --- a/amgprec/amg_c_prec_type.f90 +++ b/amgprec/amg_c_prec_type.f90 @@ -173,7 +173,7 @@ module amg_c_prec_type interface amg_memory_use - subroutine amg_cfile_prec_memory_use(prec,info,iout,root,verbosity,prefix) + subroutine amg_cfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global) import :: amg_cprec_type, psb_ipk_ implicit none ! Arguments @@ -183,6 +183,7 @@ module amg_c_prec_type 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 diff --git a/amgprec/amg_d_onelev_mod.f90 b/amgprec/amg_d_onelev_mod.f90 index 3f21a2a6..f7e7f678 100644 --- a/amgprec/amg_d_onelev_mod.f90 +++ b/amgprec/amg_d_onelev_mod.f90 @@ -276,7 +276,7 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, verbosity,prefix) + subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, 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 @@ -286,8 +286,8 @@ module amg_d_onelev_mod 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 diff --git a/amgprec/amg_d_prec_type.f90 b/amgprec/amg_d_prec_type.f90 index 90f5a2a8..e2c48cc2 100644 --- a/amgprec/amg_d_prec_type.f90 +++ b/amgprec/amg_d_prec_type.f90 @@ -173,7 +173,7 @@ module amg_d_prec_type interface amg_memory_use - subroutine amg_dfile_prec_memory_use(prec,info,iout,root,verbosity,prefix) + subroutine amg_dfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global) import :: amg_dprec_type, psb_ipk_ implicit none ! Arguments @@ -183,6 +183,7 @@ module amg_d_prec_type 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 diff --git a/amgprec/amg_s_onelev_mod.f90 b/amgprec/amg_s_onelev_mod.f90 index 9019c643..d6651396 100644 --- a/amgprec/amg_s_onelev_mod.f90 +++ b/amgprec/amg_s_onelev_mod.f90 @@ -276,7 +276,7 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, verbosity,prefix) + subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, 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 @@ -286,8 +286,8 @@ module amg_s_onelev_mod 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 diff --git a/amgprec/amg_s_prec_type.f90 b/amgprec/amg_s_prec_type.f90 index 246e763c..e64703bc 100644 --- a/amgprec/amg_s_prec_type.f90 +++ b/amgprec/amg_s_prec_type.f90 @@ -173,7 +173,7 @@ module amg_s_prec_type interface amg_memory_use - subroutine amg_sfile_prec_memory_use(prec,info,iout,root,verbosity,prefix) + subroutine amg_sfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global) import :: amg_sprec_type, psb_ipk_ implicit none ! Arguments @@ -183,6 +183,7 @@ module amg_s_prec_type 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 diff --git a/amgprec/amg_z_onelev_mod.f90 b/amgprec/amg_z_onelev_mod.f90 index 538ea9fa..16d59e44 100644 --- a/amgprec/amg_z_onelev_mod.f90 +++ b/amgprec/amg_z_onelev_mod.f90 @@ -275,7 +275,7 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, verbosity,prefix) + subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, 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 @@ -285,8 +285,8 @@ module amg_z_onelev_mod 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 diff --git a/amgprec/amg_z_prec_type.f90 b/amgprec/amg_z_prec_type.f90 index 1d1addc6..adeecf23 100644 --- a/amgprec/amg_z_prec_type.f90 +++ b/amgprec/amg_z_prec_type.f90 @@ -173,7 +173,7 @@ module amg_z_prec_type interface amg_memory_use - subroutine amg_zfile_prec_memory_use(prec,info,iout,root,verbosity,prefix) + subroutine amg_zfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global) import :: amg_zprec_type, psb_ipk_ implicit none ! Arguments @@ -183,6 +183,7 @@ module amg_z_prec_type 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 diff --git a/amgprec/impl/amg_cfile_prec_memory_use.f90 b/amgprec/impl/amg_cfile_prec_memory_use.f90 index b71cefe2..d92539f1 100644 --- a/amgprec/impl/amg_cfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_cfile_prec_memory_use.f90 @@ -65,7 +65,7 @@ ! 0: normal ! >1: increased details ! -subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) +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 @@ -79,6 +79,7 @@ subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) 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 @@ -88,6 +89,7 @@ subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) 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_ @@ -103,17 +105,24 @@ subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - + 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 (allocated(prec%precv)) then - call psb_info(ctxt,me,np) if (present(root)) then root_ = root else @@ -122,23 +131,31 @@ subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) if (root_ == -1) root_ = me if (verbosity_ >=0) then - ! - ! The preconditioner description is printed by processor psb_root_. - ! This agrees with the fact that all the parameters defining the - ! preconditioner have the same values on all the procs (this is - ! ensured by amg_precbld). - ! - if (me == root_) then + if (verbosity_ == 0) then + ! + if (me == root_) then - write(iout_,*) - write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + nlev = size(prec%precv) + do ilev=1,nlev + call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & + & iout=iout_,prefix=trim(prefix_),global=global) + end do + end if + else 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=prefix) + & iout=iout_,prefix=trim(prefix_),global=global) end do end if - end if + else write(iout_,*) trim(name), & & ': Error: no base preconditioner available, something is wrong!' diff --git a/amgprec/impl/amg_dfile_prec_memory_use.f90 b/amgprec/impl/amg_dfile_prec_memory_use.f90 index 9eb63c8b..20878ad0 100644 --- a/amgprec/impl/amg_dfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_dfile_prec_memory_use.f90 @@ -65,7 +65,7 @@ ! 0: normal ! >1: increased details ! -subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) +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 @@ -79,6 +79,7 @@ subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) 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 @@ -88,6 +89,7 @@ subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) 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_ @@ -103,17 +105,24 @@ subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - + 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 (allocated(prec%precv)) then - call psb_info(ctxt,me,np) if (present(root)) then root_ = root else @@ -122,23 +131,31 @@ subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) if (root_ == -1) root_ = me if (verbosity_ >=0) then - ! - ! The preconditioner description is printed by processor psb_root_. - ! This agrees with the fact that all the parameters defining the - ! preconditioner have the same values on all the procs (this is - ! ensured by amg_precbld). - ! - if (me == root_) then + if (verbosity_ == 0) then + ! + if (me == root_) then - write(iout_,*) - write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + nlev = size(prec%precv) + do ilev=1,nlev + call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & + & iout=iout_,prefix=trim(prefix_),global=global) + end do + end if + else 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=prefix) + & iout=iout_,prefix=trim(prefix_),global=global) end do end if - end if + else write(iout_,*) trim(name), & & ': Error: no base preconditioner available, something is wrong!' diff --git a/amgprec/impl/amg_sfile_prec_memory_use.f90 b/amgprec/impl/amg_sfile_prec_memory_use.f90 index 49373233..9a0622ce 100644 --- a/amgprec/impl/amg_sfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_sfile_prec_memory_use.f90 @@ -65,7 +65,7 @@ ! 0: normal ! >1: increased details ! -subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) +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 @@ -79,6 +79,7 @@ subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) 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 @@ -88,6 +89,7 @@ subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) 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_ @@ -103,17 +105,24 @@ subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - + 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 (allocated(prec%precv)) then - call psb_info(ctxt,me,np) if (present(root)) then root_ = root else @@ -122,23 +131,31 @@ subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) if (root_ == -1) root_ = me if (verbosity_ >=0) then - ! - ! The preconditioner description is printed by processor psb_root_. - ! This agrees with the fact that all the parameters defining the - ! preconditioner have the same values on all the procs (this is - ! ensured by amg_precbld). - ! - if (me == root_) then + if (verbosity_ == 0) then + ! + if (me == root_) then - write(iout_,*) - write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + nlev = size(prec%precv) + do ilev=1,nlev + call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & + & iout=iout_,prefix=trim(prefix_),global=global) + end do + end if + else 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=prefix) + & iout=iout_,prefix=trim(prefix_),global=global) end do end if - end if + else write(iout_,*) trim(name), & & ': Error: no base preconditioner available, something is wrong!' diff --git a/amgprec/impl/amg_zfile_prec_memory_use.f90 b/amgprec/impl/amg_zfile_prec_memory_use.f90 index 3657e9a5..c36635b4 100644 --- a/amgprec/impl/amg_zfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_zfile_prec_memory_use.f90 @@ -65,7 +65,7 @@ ! 0: normal ! >1: increased details ! -subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) +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 @@ -79,6 +79,7 @@ subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) 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 @@ -88,6 +89,7 @@ subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) 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_ @@ -103,17 +105,24 @@ subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - + 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 (allocated(prec%precv)) then - call psb_info(ctxt,me,np) if (present(root)) then root_ = root else @@ -122,23 +131,31 @@ subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix) if (root_ == -1) root_ = me if (verbosity_ >=0) then - ! - ! The preconditioner description is printed by processor psb_root_. - ! This agrees with the fact that all the parameters defining the - ! preconditioner have the same values on all the procs (this is - ! ensured by amg_precbld). - ! - if (me == root_) then + if (verbosity_ == 0) then + ! + if (me == root_) then - write(iout_,*) - write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' + nlev = size(prec%precv) + do ilev=1,nlev + call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & + & iout=iout_,prefix=trim(prefix_),global=global) + end do + end if + else 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=prefix) + & iout=iout_,prefix=trim(prefix_),global=global) end do end if - end if + else write(iout_,*) trim(name), & & ': Error: no base preconditioner available, something is wrong!' diff --git a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 index 517c3892..5163a95a 100644 --- a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 @@ -42,8 +42,8 @@ ! 0: normal ! >1: increased details ! -subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix) - +subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) + use psb_base_mod use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_memory_use Implicit None @@ -52,21 +52,25 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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 ! Local variables - integer(psb_ipk_) :: err_act + 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 + integer(psb_ipk_) :: iout_ + 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 @@ -74,34 +78,54 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi else iout_ = psb_out_unit end if - - if (present(verbosity)) then - verbosity_ = verbosity + + if (present(global)) then + global_ = global else - verbosity_ = 0 + global_ = .false. + end if + + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" end if - if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if write(iout_,*) trim(prefix_) - + 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() - + + 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 + 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 + 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() + endif 9998 continue call psb_erractionrestore(err_act) diff --git a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 index d339d3a9..d2103de2 100644 --- a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 @@ -42,8 +42,8 @@ ! 0: normal ! >1: increased details ! -subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix) - +subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) + use psb_base_mod use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_memory_use Implicit None @@ -52,21 +52,25 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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 ! Local variables - integer(psb_ipk_) :: err_act + 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 + integer(psb_ipk_) :: iout_ + 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 @@ -74,34 +78,54 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi else iout_ = psb_out_unit end if - - if (present(verbosity)) then - verbosity_ = verbosity + + if (present(global)) then + global_ = global else - verbosity_ = 0 + global_ = .false. + end if + + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" end if - if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if write(iout_,*) trim(prefix_) - + 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() - + + 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 + 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 + 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() + endif 9998 continue call psb_erractionrestore(err_act) diff --git a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 index a8c130e6..759bdf1e 100644 --- a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 @@ -42,8 +42,8 @@ ! 0: normal ! >1: increased details ! -subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix) - +subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) + use psb_base_mod use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_memory_use Implicit None @@ -52,21 +52,25 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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 ! Local variables - integer(psb_ipk_) :: err_act + 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 + integer(psb_ipk_) :: iout_ + 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 @@ -74,34 +78,54 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi else iout_ = psb_out_unit end if - - if (present(verbosity)) then - verbosity_ = verbosity + + if (present(global)) then + global_ = global else - verbosity_ = 0 + global_ = .false. + end if + + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" end if - if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if write(iout_,*) trim(prefix_) - + 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() - + + 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 + 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 + 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() + endif 9998 continue call psb_erractionrestore(err_act) diff --git a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 index db73ac0b..bb157814 100644 --- a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 @@ -42,8 +42,8 @@ ! 0: normal ! >1: increased details ! -subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix) - +subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) + use psb_base_mod use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_memory_use Implicit None @@ -52,21 +52,25 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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 ! Local variables - integer(psb_ipk_) :: err_act + 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 + integer(psb_ipk_) :: iout_ + 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 @@ -74,34 +78,54 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi else iout_ = psb_out_unit end if - - if (present(verbosity)) then - verbosity_ = verbosity + + if (present(global)) then + global_ = global else - verbosity_ = 0 + global_ = .false. + end if + + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" end if - if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if write(iout_,*) trim(prefix_) - + 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() - + + 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 + 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 + 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() + endif 9998 continue call psb_erractionrestore(err_act) From 678237cf29996dc8b896356b1b7d28553d1455e4 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 16 Mar 2024 13:31:47 +0100 Subject: [PATCH 25/51] Fixed implementation of GLOBAL vs VERBOSITY --- amgprec/amg_c_onelev_mod.f90 | 3 +- amgprec/amg_d_onelev_mod.f90 | 3 +- amgprec/amg_s_onelev_mod.f90 | 3 +- amgprec/amg_z_onelev_mod.f90 | 3 +- amgprec/impl/amg_cfile_prec_memory_use.f90 | 66 ++++++++----------- amgprec/impl/amg_dfile_prec_memory_use.f90 | 66 ++++++++----------- amgprec/impl/amg_sfile_prec_memory_use.f90 | 66 ++++++++----------- amgprec/impl/amg_zfile_prec_memory_use.f90 | 66 ++++++++----------- .../level/amg_c_base_onelev_memory_use.f90 | 25 ++++--- .../level/amg_d_base_onelev_memory_use.f90 | 25 ++++--- .../level/amg_s_base_onelev_memory_use.f90 | 25 ++++--- .../level/amg_z_base_onelev_memory_use.f90 | 25 ++++--- 12 files changed, 180 insertions(+), 196 deletions(-) diff --git a/amgprec/amg_c_onelev_mod.f90 b/amgprec/amg_c_onelev_mod.f90 index f5411e45..d926e2bf 100644 --- a/amgprec/amg_c_onelev_mod.f90 +++ b/amgprec/amg_c_onelev_mod.f90 @@ -275,7 +275,7 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, prefix,global) + 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 @@ -285,6 +285,7 @@ module amg_c_onelev_mod 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 diff --git a/amgprec/amg_d_onelev_mod.f90 b/amgprec/amg_d_onelev_mod.f90 index f7e7f678..51c482cb 100644 --- a/amgprec/amg_d_onelev_mod.f90 +++ b/amgprec/amg_d_onelev_mod.f90 @@ -276,7 +276,7 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, prefix,global) + 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 @@ -286,6 +286,7 @@ module amg_d_onelev_mod 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 diff --git a/amgprec/amg_s_onelev_mod.f90 b/amgprec/amg_s_onelev_mod.f90 index d6651396..f11b64ca 100644 --- a/amgprec/amg_s_onelev_mod.f90 +++ b/amgprec/amg_s_onelev_mod.f90 @@ -276,7 +276,7 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, prefix,global) + 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 @@ -286,6 +286,7 @@ module amg_s_onelev_mod 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 diff --git a/amgprec/amg_z_onelev_mod.f90 b/amgprec/amg_z_onelev_mod.f90 index 16d59e44..fffe88c0 100644 --- a/amgprec/amg_z_onelev_mod.f90 +++ b/amgprec/amg_z_onelev_mod.f90 @@ -275,7 +275,7 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout, prefix,global) + 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 @@ -285,6 +285,7 @@ module amg_z_onelev_mod 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 diff --git a/amgprec/impl/amg_cfile_prec_memory_use.f90 b/amgprec/impl/amg_cfile_prec_memory_use.f90 index d92539f1..922f4087 100644 --- a/amgprec/impl/amg_cfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_cfile_prec_memory_use.f90 @@ -105,7 +105,7 @@ subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - + ctxt = prec%ctxt call psb_info(ctxt,me,np) prefix_ = "" @@ -119,48 +119,34 @@ subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa else write(prefix_,'(a,i5,a)') 'Process ',me,': ' end if - - end if - if (allocated(prec%precv)) then - if (present(root)) then - root_ = root - else - root_ = psb_root_ - end if - if (root_ == -1) root_ = me + 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 (verbosity_ == 0) then - ! - if (me == root_) then - - write(iout_,*) - write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' - nlev = size(prec%precv) - do ilev=1,nlev - call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & - & iout=iout_,prefix=trim(prefix_),global=global) - end do - end if - else 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_,prefix=trim(prefix_),global=global) - end do + if (me == root_) then + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' end if - - else - write(iout_,*) trim(name), & - & ': Error: no base preconditioner available, something is wrong!' - info = -2 - return - endif + 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_dfile_prec_memory_use.f90 b/amgprec/impl/amg_dfile_prec_memory_use.f90 index 20878ad0..9423498f 100644 --- a/amgprec/impl/amg_dfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_dfile_prec_memory_use.f90 @@ -105,7 +105,7 @@ subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - + ctxt = prec%ctxt call psb_info(ctxt,me,np) prefix_ = "" @@ -119,48 +119,34 @@ subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa else write(prefix_,'(a,i5,a)') 'Process ',me,': ' end if - - end if - if (allocated(prec%precv)) then - if (present(root)) then - root_ = root - else - root_ = psb_root_ - end if - if (root_ == -1) root_ = me + 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 (verbosity_ == 0) then - ! - if (me == root_) then - - write(iout_,*) - write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' - nlev = size(prec%precv) - do ilev=1,nlev - call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & - & iout=iout_,prefix=trim(prefix_),global=global) - end do - end if - else 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_,prefix=trim(prefix_),global=global) - end do + if (me == root_) then + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' end if - - else - write(iout_,*) trim(name), & - & ': Error: no base preconditioner available, something is wrong!' - info = -2 - return - endif + 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_sfile_prec_memory_use.f90 b/amgprec/impl/amg_sfile_prec_memory_use.f90 index 9a0622ce..ea776c2b 100644 --- a/amgprec/impl/amg_sfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_sfile_prec_memory_use.f90 @@ -105,7 +105,7 @@ subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - + ctxt = prec%ctxt call psb_info(ctxt,me,np) prefix_ = "" @@ -119,48 +119,34 @@ subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa else write(prefix_,'(a,i5,a)') 'Process ',me,': ' end if - - end if - if (allocated(prec%precv)) then - if (present(root)) then - root_ = root - else - root_ = psb_root_ - end if - if (root_ == -1) root_ = me + 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 (verbosity_ == 0) then - ! - if (me == root_) then - - write(iout_,*) - write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' - nlev = size(prec%precv) - do ilev=1,nlev - call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & - & iout=iout_,prefix=trim(prefix_),global=global) - end do - end if - else 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_,prefix=trim(prefix_),global=global) - end do + if (me == root_) then + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' end if - - else - write(iout_,*) trim(name), & - & ': Error: no base preconditioner available, something is wrong!' - info = -2 - return - endif + 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_zfile_prec_memory_use.f90 b/amgprec/impl/amg_zfile_prec_memory_use.f90 index c36635b4..e54b13ad 100644 --- a/amgprec/impl/amg_zfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_zfile_prec_memory_use.f90 @@ -105,7 +105,7 @@ subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - + ctxt = prec%ctxt call psb_info(ctxt,me,np) prefix_ = "" @@ -119,48 +119,34 @@ subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa else write(prefix_,'(a,i5,a)') 'Process ',me,': ' end if - - end if - if (allocated(prec%precv)) then - if (present(root)) then - root_ = root - else - root_ = psb_root_ - end if - if (root_ == -1) root_ = me + 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 (verbosity_ == 0) then - ! - if (me == root_) then - - write(iout_,*) - write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' - nlev = size(prec%precv) - do ilev=1,nlev - call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, & - & iout=iout_,prefix=trim(prefix_),global=global) - end do - end if - else 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_,prefix=trim(prefix_),global=global) - end do + if (me == root_) then + write(iout_,*) + write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage' end if - - else - write(iout_,*) trim(name), & - & ': Error: no base preconditioner available, something is wrong!' - info = -2 - return - endif + 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/level/amg_c_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 index 5163a95a..9cfc369e 100644 --- a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 @@ -42,7 +42,7 @@ ! 0: normal ! >1: increased details ! -subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) +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 @@ -53,6 +53,7 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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 @@ -60,7 +61,7 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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_ + integer(psb_ipk_) :: iout_, verbosity_ logical :: coarse, global_ character(1024) :: prefix_ integer(psb_epk_), allocatable :: sz(:) @@ -79,6 +80,12 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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 @@ -119,12 +126,14 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) end if else - 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() + if ((me == 0).or.(verbosity_>0)) then + 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 diff --git a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 index d2103de2..1e9bb9a9 100644 --- a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 @@ -42,7 +42,7 @@ ! 0: normal ! >1: increased details ! -subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) +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 @@ -53,6 +53,7 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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 @@ -60,7 +61,7 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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_ + integer(psb_ipk_) :: iout_, verbosity_ logical :: coarse, global_ character(1024) :: prefix_ integer(psb_epk_), allocatable :: sz(:) @@ -79,6 +80,12 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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 @@ -119,12 +126,14 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) end if else - 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() + if ((me == 0).or.(verbosity_>0)) then + 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 diff --git a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 index 759bdf1e..53be7406 100644 --- a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 @@ -42,7 +42,7 @@ ! 0: normal ! >1: increased details ! -subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) +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 @@ -53,6 +53,7 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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 @@ -60,7 +61,7 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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_ + integer(psb_ipk_) :: iout_, verbosity_ logical :: coarse, global_ character(1024) :: prefix_ integer(psb_epk_), allocatable :: sz(:) @@ -79,6 +80,12 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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 @@ -119,12 +126,14 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) end if else - 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() + if ((me == 0).or.(verbosity_>0)) then + 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 diff --git a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 index bb157814..cf9ddcbe 100644 --- a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 @@ -42,7 +42,7 @@ ! 0: normal ! >1: increased details ! -subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) +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 @@ -53,6 +53,7 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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 @@ -60,7 +61,7 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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_ + integer(psb_ipk_) :: iout_, verbosity_ logical :: coarse, global_ character(1024) :: prefix_ integer(psb_epk_), allocatable :: sz(:) @@ -79,6 +80,12 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) 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 @@ -119,12 +126,14 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,prefix,global) end if else - 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() + if ((me == 0).or.(verbosity_>0)) then + 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 From af3fda96906816a3684dbbc63a4f218361e7881b Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 16 Mar 2024 14:26:19 +0100 Subject: [PATCH 26/51] Additional output fixes for memory_use --- amgprec/impl/amg_cfile_prec_memory_use.f90 | 4 ++-- amgprec/impl/amg_dfile_prec_memory_use.f90 | 4 ++-- amgprec/impl/amg_sfile_prec_memory_use.f90 | 4 ++-- amgprec/impl/amg_zfile_prec_memory_use.f90 | 4 ++-- .../impl/level/amg_c_base_onelev_memory_use.f90 | 15 ++++++++++----- .../impl/level/amg_d_base_onelev_memory_use.f90 | 15 ++++++++++----- .../impl/level/amg_s_base_onelev_memory_use.f90 | 15 ++++++++++----- .../impl/level/amg_z_base_onelev_memory_use.f90 | 15 ++++++++++----- 8 files changed, 48 insertions(+), 28 deletions(-) diff --git a/amgprec/impl/amg_cfile_prec_memory_use.f90 b/amgprec/impl/amg_cfile_prec_memory_use.f90 index 922f4087..c578358c 100644 --- a/amgprec/impl/amg_cfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_cfile_prec_memory_use.f90 @@ -109,11 +109,11 @@ subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa ctxt = prec%ctxt call psb_info(ctxt,me,np) prefix_ = "" - if (verbosity == 0) then + if (verbosity_ == 0) then if (present(prefix)) then prefix_ = prefix end if - else if (verbosity > 0) then + else if (verbosity_ > 0) then if (present(prefix)) then write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': ' else diff --git a/amgprec/impl/amg_dfile_prec_memory_use.f90 b/amgprec/impl/amg_dfile_prec_memory_use.f90 index 9423498f..d10cd5f3 100644 --- a/amgprec/impl/amg_dfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_dfile_prec_memory_use.f90 @@ -109,11 +109,11 @@ subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa ctxt = prec%ctxt call psb_info(ctxt,me,np) prefix_ = "" - if (verbosity == 0) then + if (verbosity_ == 0) then if (present(prefix)) then prefix_ = prefix end if - else if (verbosity > 0) then + else if (verbosity_ > 0) then if (present(prefix)) then write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': ' else diff --git a/amgprec/impl/amg_sfile_prec_memory_use.f90 b/amgprec/impl/amg_sfile_prec_memory_use.f90 index ea776c2b..bde5412a 100644 --- a/amgprec/impl/amg_sfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_sfile_prec_memory_use.f90 @@ -109,11 +109,11 @@ subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa ctxt = prec%ctxt call psb_info(ctxt,me,np) prefix_ = "" - if (verbosity == 0) then + if (verbosity_ == 0) then if (present(prefix)) then prefix_ = prefix end if - else if (verbosity > 0) then + else if (verbosity_ > 0) then if (present(prefix)) then write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': ' else diff --git a/amgprec/impl/amg_zfile_prec_memory_use.f90 b/amgprec/impl/amg_zfile_prec_memory_use.f90 index e54b13ad..145ce044 100644 --- a/amgprec/impl/amg_zfile_prec_memory_use.f90 +++ b/amgprec/impl/amg_zfile_prec_memory_use.f90 @@ -109,11 +109,11 @@ subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,globa ctxt = prec%ctxt call psb_info(ctxt,me,np) prefix_ = "" - if (verbosity == 0) then + if (verbosity_ == 0) then if (present(prefix)) then prefix_ = prefix end if - else if (verbosity > 0) then + else if (verbosity_ > 0) then if (present(prefix)) then write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': ' else diff --git a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 index 9cfc369e..f4147bb3 100644 --- a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 @@ -100,11 +100,6 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi write(iout_,*) trim(prefix_) - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if if (global_) then allocate(sz(6)) @@ -117,6 +112,11 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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) @@ -127,6 +127,11 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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() diff --git a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 index 1e9bb9a9..0a5e2066 100644 --- a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 @@ -100,11 +100,6 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi write(iout_,*) trim(prefix_) - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if if (global_) then allocate(sz(6)) @@ -117,6 +112,11 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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) @@ -127,6 +127,11 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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() diff --git a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 index 53be7406..f59d8dd9 100644 --- a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 @@ -100,11 +100,6 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi write(iout_,*) trim(prefix_) - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if if (global_) then allocate(sz(6)) @@ -117,6 +112,11 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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) @@ -127,6 +127,11 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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() diff --git a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 index cf9ddcbe..4c1e3432 100644 --- a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 @@ -100,11 +100,6 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi write(iout_,*) trim(prefix_) - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if if (global_) then allocate(sz(6)) @@ -117,6 +112,11 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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) @@ -127,6 +127,11 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi 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() From 83d435b49e36df11961cc58453e4f69db7b03ad6 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 16 Mar 2024 15:22:24 +0100 Subject: [PATCH 27/51] Default GLOBAL=.true. for MEMORY_USE --- amgprec/impl/level/amg_c_base_onelev_memory_use.f90 | 2 +- amgprec/impl/level/amg_d_base_onelev_memory_use.f90 | 2 +- amgprec/impl/level/amg_s_base_onelev_memory_use.f90 | 2 +- amgprec/impl/level/amg_z_base_onelev_memory_use.f90 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 index f4147bb3..4b58000d 100644 --- a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 @@ -89,7 +89,7 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi if (present(global)) then global_ = global else - global_ = .false. + global_ = .true. end if if (present(prefix)) 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 index 0a5e2066..25534fd0 100644 --- a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 @@ -89,7 +89,7 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi if (present(global)) then global_ = global else - global_ = .false. + global_ = .true. end if if (present(prefix)) 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 index f59d8dd9..9709ba3e 100644 --- a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 @@ -89,7 +89,7 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi if (present(global)) then global_ = global else - global_ = .false. + global_ = .true. end if if (present(prefix)) 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 index 4c1e3432..0e12a6bc 100644 --- a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 @@ -89,7 +89,7 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi if (present(global)) then global_ = global else - global_ = .false. + global_ = .true. end if if (present(prefix)) then From e83bde6896431443f2d9f89c9ef1fbf0522996eb Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 17 Apr 2024 14:45:20 +0200 Subject: [PATCH 28/51] New timings --- amgprec/amg_base_prec_type.F90 | 3 + amgprec/amg_d_matchboxp_mod.f90 | 6 +- .../amg_d_parmatch_aggregator_tprol.F90 | 2 +- .../amg_d_parmatch_spmm_bld_inner.F90 | 2 +- amgprec/impl/aggregator/amg_d_ptap_bld.f90 | 2 +- .../impl/aggregator/amg_d_soc2_map_bld.F90 | 2 +- amgprec/impl/amg_dmlprec_aply.f90 | 34 +++++++++- .../amg_d_poly_smoother_apply_vect.f90 | 66 ++++++++++++++++++- .../impl/smoother/amg_d_poly_smoother_bld.f90 | 6 +- .../smoother/amg_d_poly_smoother_cseti.f90 | 2 +- 10 files changed, 112 insertions(+), 13 deletions(-) diff --git a/amgprec/amg_base_prec_type.F90 b/amgprec/amg_base_prec_type.F90 index 3434d675..60aacaec 100644 --- a/amgprec/amg_base_prec_type.F90 +++ b/amgprec/amg_base_prec_type.F90 @@ -326,6 +326,7 @@ module amg_base_prec_type 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 @@ -575,6 +576,8 @@ contains 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') diff --git a/amgprec/amg_d_matchboxp_mod.f90 b/amgprec/amg_d_matchboxp_mod.f90 index e19ce617..8b9c3bb6 100644 --- a/amgprec/amg_d_matchboxp_mod.f90 +++ b/amgprec/amg_d_matchboxp_mod.f90 @@ -145,7 +145,7 @@ contains logical, parameter :: dump=.false., debug=.false., dump_mate=.false., & & debug_ilaggr=.false., debug_sync=.false., debug_mate=.false. integer(psb_ipk_), save :: idx_bldmtc=-1, idx_phase1=-1, idx_phase2=-1, idx_phase3=-1 - logical, parameter :: do_timings=.true. + logical, parameter :: do_timings=.false. integer, parameter :: ilaggr_neginit=-1, ilaggr_nonlocal=-2 ictxt = desc_a%get_ctxt() @@ -608,7 +608,7 @@ contains logical, parameter :: old_style=.false., sort_minp=.true. character(len=40) :: name='build_matching', fname integer(psb_ipk_), save :: idx_cmboxp=-1, idx_bldahat=-1, idx_phase2=-1, idx_phase3=-1 - logical, parameter :: do_timings=.true. + logical, parameter :: do_timings=.false. ictxt = desc_a%get_ctxt() call psb_info(ictxt,iam,np) @@ -810,7 +810,7 @@ contains character(len=80) :: aname real(psb_dpk_), parameter :: eps=epsilon(1.d0) integer(psb_ipk_), save :: idx_glbt=-1, idx_phase1=-1, idx_phase2=-1 - logical, parameter :: do_timings=.true. + logical, parameter :: do_timings=.false. logical, parameter :: debug_symmetry = .false., check_size=.false. logical, parameter :: unroll_logtrans=.false. diff --git a/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 b/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 index f23869b7..3187aa70 100644 --- a/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 +++ b/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 @@ -88,7 +88,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& type(psb_ldspmat_type) :: tmp_prol, tmp_pg, tmp_restr type(psb_desc_type) :: tmp_desc_ac, tmp_desc_ax, tmp_desc_p integer(psb_ipk_), save :: idx_mboxp=-1, idx_spmmbld=-1, idx_sweeps_mult=-1 - logical, parameter :: dump=.false., do_timings=.true., debug=.false., & + logical, parameter :: dump=.false., do_timings=.false., debug=.false., & & dump_prol_restr=.false. name='d_parmatch_tprol' diff --git a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 index 04d89b2f..aa60fe20 100644 --- a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 +++ b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 @@ -131,7 +131,7 @@ subroutine amg_d_parmatch_spmm_bld_inner(a_csr,desc_a,ilaggr,nlaggr,parms,& & nzt, naggrm1, naggrp1, i, k integer(psb_lpk_), allocatable :: ia(:),ja(:) !integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza, nrpsave, ncpsave, nzpsave - logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false. + logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false. integer(psb_ipk_), save :: idx_spspmm=-1, idx_prolcnv=-1, idx_proltrans=-1, idx_asb=-1 name='amg_parmatch_spmm_bld_inner' diff --git a/amgprec/impl/aggregator/amg_d_ptap_bld.f90 b/amgprec/impl/aggregator/amg_d_ptap_bld.f90 index 4006c04c..4ca7d444 100644 --- a/amgprec/impl/aggregator/amg_d_ptap_bld.f90 +++ b/amgprec/impl/aggregator/amg_d_ptap_bld.f90 @@ -486,7 +486,7 @@ subroutine amg_ld_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,& integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, & & nzt, naggrm1, naggrp1, i, k integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza - logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false. + logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false. integer(psb_ipk_), save :: idx_spspmm=-1 name='amg_ptap_bld' diff --git a/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 b/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 index 345cd1ad..82972fda 100644 --- a/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 @@ -104,7 +104,7 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in character(len=20) :: name, ch_err integer(psb_ipk_), save :: idx_soc2_p1=-1, idx_soc2_p2=-1, idx_soc2_p3=-1 integer(psb_ipk_), save :: idx_soc2_p0=-1 - logical, parameter :: do_timings=.true. + logical, parameter :: do_timings=.false. info=psb_success_ name = 'amg_soc2_map_bld' diff --git a/amgprec/impl/amg_dmlprec_aply.f90 b/amgprec/impl/amg_dmlprec_aply.f90 index 983fb937..33a64c31 100644 --- a/amgprec/impl/amg_dmlprec_aply.f90 +++ b/amgprec/impl/amg_dmlprec_aply.f90 @@ -591,6 +591,8 @@ contains integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post character(len=20) :: name + logical, parameter :: do_timings=.true. + integer(psb_ipk_), save :: ml_mlt_smth=-1, ml_mlt_rp=-1, ml_mlt_rsd=-1 name = 'inner_inner_mult' info = psb_success_ @@ -608,6 +610,12 @@ contains if(debug_level > 1) then write(debug_unit,*) me,' inner_mult at level ',level end if + if ((do_timings).and.(ml_mlt_smth==-1)) & + & ml_mlt_smth = psb_get_timer_idx("ML-MLT: smoother ") + if ((do_timings).and.(ml_mlt_rp==-1)) & + & ml_mlt_rp = psb_get_timer_idx("ML-MLT: RestProl") + if ((do_timings).and.(ml_mlt_rsd==-1)) & + & ml_mlt_rsd = psb_get_timer_idx("ML-MLT: Residual") sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre @@ -623,7 +631,7 @@ contains ! Apply the first smoother ! The residual has been prepared before the recursive call. ! - + if (do_timings) call psb_tic(ml_mlt_smth) if (pre) then if (me >=0) then !!$ write(0,*) me,'Applying smoother pre ', level @@ -646,10 +654,13 @@ contains end if end if endif + if (do_timings) call psb_toc(ml_mlt_smth) + ! ! Compute the residual for next level and call recursively ! if (pre) then + if (do_timings) call psb_tic(ml_mlt_rsd) call psb_geaxpby(done,vx2l,& & dzero,vty,& & base_desc,info) @@ -657,6 +668,9 @@ contains if (info == psb_success_) call psb_spmm(-done,base_a,& & vy2l,done,vty,& & base_desc,info,work=work,trans=trans) + if (do_timings) call psb_toc(ml_mlt_rsd) + if (do_timings) call psb_tic(ml_mlt_rp) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -671,7 +685,9 @@ contains & a_err='Error during restriction') goto 9999 end if + if (do_timings) call psb_toc(ml_mlt_rp) else + if (do_timings) call psb_tic(ml_mlt_rp) ! Shortcut: just transfer x2l. call p%precv(level+1)%map_rstr(done,vx2l,& & dzero,p%precv(level+1)%wrk%vx2l,& @@ -682,6 +698,7 @@ contains & a_err='Error during restriction') goto 9999 end if + if (do_timings) call psb_toc(ml_mlt_rp) endif call inner_ml_aply(level+1,p,trans,work,info) @@ -689,10 +706,12 @@ contains ! ! Apply the prolongator ! + if (do_timings) call psb_tic(ml_mlt_rp) call p%precv(level+1)%map_prol(done,& & p%precv(level+1)%wrk%vy2l,done,vy2l,& & info,work=work,& & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) + if (do_timings) call psb_toc(ml_mlt_rp) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -700,7 +719,7 @@ contains end if if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - + if (do_timings) call psb_tic(ml_mlt_rsd) if (me >=0) then call psb_geaxpby(done,vx2l, dzero,vty,& & base_desc,info) @@ -708,10 +727,13 @@ contains & vy2l,done,vty,& & base_desc,info,work=work,trans=trans) end if + if (do_timings) call psb_toc(ml_mlt_rsd) + if (do_timings) call psb_tic(ml_mlt_rp) if (info == psb_success_) & & call p%precv(level+1)%map_rstr(done,vty,& & dzero,p%precv(level+1)%wrk%vx2l,info,work=work,& & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) + if (do_timings) call psb_toc(ml_mlt_rp) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during W-cycle restriction') @@ -720,10 +742,12 @@ contains call inner_ml_aply(level+1,p,trans,work,info) + if (do_timings) call psb_tic(ml_mlt_rp) if (info == psb_success_) call p%precv(level+1)%map_prol(done, & & p%precv(level+1)%wrk%vy2l,done,vy2l,& & info,work=work,& & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) + if (do_timings) call psb_toc(ml_mlt_rp) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -736,6 +760,7 @@ contains if (post) then if (me >=0) then + if (do_timings) call psb_tic(ml_mlt_rsd) call psb_geaxpby(done,vx2l,& & dzero,vty,& & base_desc,info) @@ -747,7 +772,9 @@ contains & a_err='Error during residue') goto 9999 end if + if (do_timings) call psb_toc(ml_mlt_rsd) + if (do_timings) call psb_tic(ml_mlt_smth) ! ! Apply the second smoother ! @@ -762,6 +789,7 @@ contains & vty,done,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if + if (do_timings) call psb_toc(ml_mlt_smth) end if if (info /= psb_success_) then @@ -774,12 +802,14 @@ contains else if (level == nlev) then !!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal() + if (do_timings) call psb_tic(ml_mlt_smth) if (me >=0) then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& & vx2l,dzero,vy2l,base_desc, trans,& & sweeps,work,wv,info) end if + if (do_timings) call psb_toc(ml_mlt_smth) !!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal() else diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index 32926bd6..ac89c523 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -64,6 +64,9 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character :: trans_, init_ real(psb_dpk_) :: res, resdenum character(len=20) :: name='d_poly_smoother_apply_v' + 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 call psb_erractionsave(err_act) @@ -93,6 +96,18 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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() @@ -125,6 +140,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case(sm%variant) case(amg_poly_lottes_) + if (do_timings) call psb_tic(poly_1) block real(psb_dpk_) :: cz, cr ! b == x @@ -154,8 +170,10 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! x_k = x_{k-1} + z_k end do 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 @@ -194,34 +212,51 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! x_k = x_{k-1} + z_k end do 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 ! - + sm%rho_ba = 1.12d0 + !write(0,*) 'Parameter: ',sm%cf_a,sm%rho_ba + 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) + if (do_timings) call psb_tic(poly_vect) call psb_geaxpby((done/sm%rho_ba),ty,dzero,r,desc_data,info) + !write(0,*) 'POLY_NEW Iteration',0,' :',psb_genrm2(r,desc_data,info) if (.false.) then call psb_geaxpby((done/theta),r,dzero,tz,desc_data,info) call psb_geaxpby(done,tz,done,tx,desc_data,info) else call psb_abgdxyz((done/theta),dzero,done,done,r,tz,tx,desc_data,info) end if + 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) + if (do_timings) call psb_tic(poly_vect) + + !write(0,*) 'POLY_NEW Iteration',i,' :',psb_genrm2(r,desc_data,info) ! ! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1} @@ -236,9 +271,36 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& !!$ write(0,*) 'Polynomial smoother NEW ',i,res ! x_k = x_{k-1} + z_k rho_old = rho + if (do_timings) call psb_toc(poly_vect) + end do + end block + if (do_timings) call psb_toc(poly_3) + + case(amg_poly_dbg_) + block + real(psb_dpk_) :: sigma, theta, delta, rho_old, rho + ! b == x + ! x == tx + ! + write(0,*) 'Parameter: ',sm%cf_a + theta = (done+sm%cf_a)/2 + delta = (done-sm%cf_a)/2 + sigma = theta/delta + rho_old = done/sigma + call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + call psb_geaxpby(done,ty,dzero,r,desc_data,info) + call psb_geaxpby(done/theta,r,dzero,tz,desc_data,info) + write(0,*) 'POLY_DBG Iteration',0,' :',psb_genrm2(r,desc_data,info) + do i=1, sm%pdegree + call psb_geaxpby(done,tz,done,tx,desc_data,info) + call psb_spmm(done,sm%pa,tz,dzero,ty,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(-(done),ty,done,r,desc_data,trans_,aux,wv(5:),info,init='Z') + write(0,*) 'POLY_DBG Iteration',i,' :',psb_genrm2(r,desc_data,info) + rho = done/(2*sigma - rho_old) + call psb_geaxpby((2*rho/delta),r,rho*rho_old,tz,desc_data,info) + rho_old = rho end do end block - case default info=psb_err_internal_error_ diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index dd156912..77b1aa3d 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -87,10 +87,14 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) & a_err='invalid sm%degree for poly_beta') goto 9999 end if - case(amg_poly_new_) + case(amg_poly_new_, amg_poly_dbg_) if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then !Ok +!!$ write(0,*) 'Vector: ' +!!$ do i=1,size(amg_d_poly_a_vect) +!!$ write(0,*) i,amg_d_poly_a_vect(i) +!!$ end do sm%cf_a = amg_d_poly_a_vect(sm%pdegree) else info = psb_err_internal_error_ diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 index 916fb5e6..5d8d1169 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 @@ -58,7 +58,7 @@ subroutine amg_d_poly_smoother_cseti(sm,what,val,info,idx) sm%pdegree = val case('POLY_VARIANT') select case(val) - case(amg_poly_lottes_,amg_poly_lottes_beta_,amg_poly_new_) + case(amg_poly_lottes_,amg_poly_lottes_beta_,amg_poly_new_,amg_poly_dbg_) sm%variant = val case default write(0,*) 'Invalid choice for POLY_VARIANT, defaulting to amg_poly_lottes_',val From 74dccb6c44c916bd7df9256aeda40914b6843829 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Mon, 22 Apr 2024 07:52:14 +0000 Subject: [PATCH 29/51] Added timers and removed unuseful spmm --- amgprec/amg_d_matchboxp_mod.f90 | 6 +- .../amg_d_parmatch_aggregator_tprol.F90 | 2 +- .../amg_d_parmatch_spmm_bld_inner.F90 | 2 +- amgprec/impl/aggregator/amg_d_ptap_bld.f90 | 2 +- .../impl/aggregator/amg_d_soc2_map_bld.F90 | 2 +- amgprec/impl/amg_dmlprec_aply.f90 | 34 +---- .../amg_d_poly_smoother_apply_vect.f90 | 144 ++++++------------ .../impl/smoother/amg_d_poly_smoother_bld.f90 | 6 +- .../smoother/amg_d_poly_smoother_cseti.f90 | 2 +- .../amg_s_poly_smoother_apply_vect.f90 | 130 ++++++++-------- 10 files changed, 127 insertions(+), 203 deletions(-) diff --git a/amgprec/amg_d_matchboxp_mod.f90 b/amgprec/amg_d_matchboxp_mod.f90 index 8b9c3bb6..e19ce617 100644 --- a/amgprec/amg_d_matchboxp_mod.f90 +++ b/amgprec/amg_d_matchboxp_mod.f90 @@ -145,7 +145,7 @@ contains logical, parameter :: dump=.false., debug=.false., dump_mate=.false., & & debug_ilaggr=.false., debug_sync=.false., debug_mate=.false. integer(psb_ipk_), save :: idx_bldmtc=-1, idx_phase1=-1, idx_phase2=-1, idx_phase3=-1 - logical, parameter :: do_timings=.false. + logical, parameter :: do_timings=.true. integer, parameter :: ilaggr_neginit=-1, ilaggr_nonlocal=-2 ictxt = desc_a%get_ctxt() @@ -608,7 +608,7 @@ contains logical, parameter :: old_style=.false., sort_minp=.true. character(len=40) :: name='build_matching', fname integer(psb_ipk_), save :: idx_cmboxp=-1, idx_bldahat=-1, idx_phase2=-1, idx_phase3=-1 - logical, parameter :: do_timings=.false. + logical, parameter :: do_timings=.true. ictxt = desc_a%get_ctxt() call psb_info(ictxt,iam,np) @@ -810,7 +810,7 @@ contains character(len=80) :: aname real(psb_dpk_), parameter :: eps=epsilon(1.d0) integer(psb_ipk_), save :: idx_glbt=-1, idx_phase1=-1, idx_phase2=-1 - logical, parameter :: do_timings=.false. + logical, parameter :: do_timings=.true. logical, parameter :: debug_symmetry = .false., check_size=.false. logical, parameter :: unroll_logtrans=.false. diff --git a/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 b/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 index 3187aa70..f23869b7 100644 --- a/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 +++ b/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 @@ -88,7 +88,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& type(psb_ldspmat_type) :: tmp_prol, tmp_pg, tmp_restr type(psb_desc_type) :: tmp_desc_ac, tmp_desc_ax, tmp_desc_p integer(psb_ipk_), save :: idx_mboxp=-1, idx_spmmbld=-1, idx_sweeps_mult=-1 - logical, parameter :: dump=.false., do_timings=.false., debug=.false., & + logical, parameter :: dump=.false., do_timings=.true., debug=.false., & & dump_prol_restr=.false. name='d_parmatch_tprol' diff --git a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 index aa60fe20..04d89b2f 100644 --- a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 +++ b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 @@ -131,7 +131,7 @@ subroutine amg_d_parmatch_spmm_bld_inner(a_csr,desc_a,ilaggr,nlaggr,parms,& & nzt, naggrm1, naggrp1, i, k integer(psb_lpk_), allocatable :: ia(:),ja(:) !integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza, nrpsave, ncpsave, nzpsave - logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false. + logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false. integer(psb_ipk_), save :: idx_spspmm=-1, idx_prolcnv=-1, idx_proltrans=-1, idx_asb=-1 name='amg_parmatch_spmm_bld_inner' diff --git a/amgprec/impl/aggregator/amg_d_ptap_bld.f90 b/amgprec/impl/aggregator/amg_d_ptap_bld.f90 index 4ca7d444..4006c04c 100644 --- a/amgprec/impl/aggregator/amg_d_ptap_bld.f90 +++ b/amgprec/impl/aggregator/amg_d_ptap_bld.f90 @@ -486,7 +486,7 @@ subroutine amg_ld_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,& integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, & & nzt, naggrm1, naggrp1, i, k integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza - logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false. + logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false. integer(psb_ipk_), save :: idx_spspmm=-1 name='amg_ptap_bld' diff --git a/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 b/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 index 82972fda..345cd1ad 100644 --- a/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 @@ -104,7 +104,7 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in character(len=20) :: name, ch_err integer(psb_ipk_), save :: idx_soc2_p1=-1, idx_soc2_p2=-1, idx_soc2_p3=-1 integer(psb_ipk_), save :: idx_soc2_p0=-1 - logical, parameter :: do_timings=.false. + logical, parameter :: do_timings=.true. info=psb_success_ name = 'amg_soc2_map_bld' diff --git a/amgprec/impl/amg_dmlprec_aply.f90 b/amgprec/impl/amg_dmlprec_aply.f90 index 33a64c31..983fb937 100644 --- a/amgprec/impl/amg_dmlprec_aply.f90 +++ b/amgprec/impl/amg_dmlprec_aply.f90 @@ -591,8 +591,6 @@ contains integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post character(len=20) :: name - logical, parameter :: do_timings=.true. - integer(psb_ipk_), save :: ml_mlt_smth=-1, ml_mlt_rp=-1, ml_mlt_rsd=-1 name = 'inner_inner_mult' info = psb_success_ @@ -610,12 +608,6 @@ contains if(debug_level > 1) then write(debug_unit,*) me,' inner_mult at level ',level end if - if ((do_timings).and.(ml_mlt_smth==-1)) & - & ml_mlt_smth = psb_get_timer_idx("ML-MLT: smoother ") - if ((do_timings).and.(ml_mlt_rp==-1)) & - & ml_mlt_rp = psb_get_timer_idx("ML-MLT: RestProl") - if ((do_timings).and.(ml_mlt_rsd==-1)) & - & ml_mlt_rsd = psb_get_timer_idx("ML-MLT: Residual") sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre @@ -631,7 +623,7 @@ contains ! Apply the first smoother ! The residual has been prepared before the recursive call. ! - if (do_timings) call psb_tic(ml_mlt_smth) + if (pre) then if (me >=0) then !!$ write(0,*) me,'Applying smoother pre ', level @@ -654,13 +646,10 @@ contains end if end if endif - if (do_timings) call psb_toc(ml_mlt_smth) - ! ! Compute the residual for next level and call recursively ! if (pre) then - if (do_timings) call psb_tic(ml_mlt_rsd) call psb_geaxpby(done,vx2l,& & dzero,vty,& & base_desc,info) @@ -668,9 +657,6 @@ contains if (info == psb_success_) call psb_spmm(-done,base_a,& & vy2l,done,vty,& & base_desc,info,work=work,trans=trans) - if (do_timings) call psb_toc(ml_mlt_rsd) - if (do_timings) call psb_tic(ml_mlt_rp) - if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -685,9 +671,7 @@ contains & a_err='Error during restriction') goto 9999 end if - if (do_timings) call psb_toc(ml_mlt_rp) else - if (do_timings) call psb_tic(ml_mlt_rp) ! Shortcut: just transfer x2l. call p%precv(level+1)%map_rstr(done,vx2l,& & dzero,p%precv(level+1)%wrk%vx2l,& @@ -698,7 +682,6 @@ contains & a_err='Error during restriction') goto 9999 end if - if (do_timings) call psb_toc(ml_mlt_rp) endif call inner_ml_aply(level+1,p,trans,work,info) @@ -706,12 +689,10 @@ contains ! ! Apply the prolongator ! - if (do_timings) call psb_tic(ml_mlt_rp) call p%precv(level+1)%map_prol(done,& & p%precv(level+1)%wrk%vy2l,done,vy2l,& & info,work=work,& & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) - if (do_timings) call psb_toc(ml_mlt_rp) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -719,7 +700,7 @@ contains end if if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - if (do_timings) call psb_tic(ml_mlt_rsd) + if (me >=0) then call psb_geaxpby(done,vx2l, dzero,vty,& & base_desc,info) @@ -727,13 +708,10 @@ contains & vy2l,done,vty,& & base_desc,info,work=work,trans=trans) end if - if (do_timings) call psb_toc(ml_mlt_rsd) - if (do_timings) call psb_tic(ml_mlt_rp) if (info == psb_success_) & & call p%precv(level+1)%map_rstr(done,vty,& & dzero,p%precv(level+1)%wrk%vx2l,info,work=work,& & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) - if (do_timings) call psb_toc(ml_mlt_rp) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during W-cycle restriction') @@ -742,12 +720,10 @@ contains call inner_ml_aply(level+1,p,trans,work,info) - if (do_timings) call psb_tic(ml_mlt_rp) if (info == psb_success_) call p%precv(level+1)%map_prol(done, & & p%precv(level+1)%wrk%vy2l,done,vy2l,& & info,work=work,& & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) - if (do_timings) call psb_toc(ml_mlt_rp) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -760,7 +736,6 @@ contains if (post) then if (me >=0) then - if (do_timings) call psb_tic(ml_mlt_rsd) call psb_geaxpby(done,vx2l,& & dzero,vty,& & base_desc,info) @@ -772,9 +747,7 @@ contains & a_err='Error during residue') goto 9999 end if - if (do_timings) call psb_toc(ml_mlt_rsd) - if (do_timings) call psb_tic(ml_mlt_smth) ! ! Apply the second smoother ! @@ -789,7 +762,6 @@ contains & vty,done,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if - if (do_timings) call psb_toc(ml_mlt_smth) end if if (info /= psb_success_) then @@ -802,14 +774,12 @@ contains else if (level == nlev) then !!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal() - if (do_timings) call psb_tic(ml_mlt_smth) if (me >=0) then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& & vx2l,dzero,vy2l,base_desc, trans,& & sweeps,work,wv,info) end if - if (do_timings) call psb_toc(ml_mlt_smth) !!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal() else diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 index ac89c523..3c181841 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,wv,info,init,initu) + & sweeps,work,wv,info,init,initu) use psb_base_mod use amg_d_diag_solver @@ -55,6 +55,10 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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 @@ -64,9 +68,6 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character :: trans_, init_ real(psb_dpk_) :: res, resdenum character(len=20) :: name='d_poly_smoother_apply_v' - 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 call psb_erractionsave(err_act) @@ -95,7 +96,7 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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)) & @@ -146,35 +147,33 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! b == x ! x == tx ! - do i=1, sm%pdegree + do i=1, sm%pdegree-1 ! B r_{k-1} - call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + 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 (.false.) then - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(done,tz,done,tx,desc_data,info) - else - call psb_abgdxyz(cr,cz,done,done,ty,tz,tx,desc_data,info) - end if - if (.false.) then - call psb_geaxpby(done,x,dzero,r,desc_data,info) - call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) - else - call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) - end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother LOTTES',i,res - ! x_k = x_{k-1} + z_k + 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 @@ -188,43 +187,36 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& sm%poly_beta(1:sm%pdegree) = amg_d_poly_beta_mat(1:sm%pdegree,sm%pdegree) end if - do i=1, sm%pdegree + 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 (.false.) then - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(sm%poly_beta(i),tz,done,tx,desc_data,info) - else - call psb_abgdxyz(cr,cz,sm%poly_beta(i),done,ty,tz,tx,desc_data,info) - end if - if (.false.) then - call psb_geaxpby(done,x,dzero,r,desc_data,info) - call psb_spmm(-done,sm%pa,tx,done,r,desc_data,info,work=aux,trans=trans_) - else - call psb_spmm(-done,sm%pa,tz,done,r,desc_data,info,work=aux,trans=trans_) - end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother LOTTES_BETA',i,res - ! x_k = x_{k-1} + z_k + 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 ! - sm%rho_ba = 1.12d0 - !write(0,*) 'Parameter: ',sm%cf_a,sm%rho_ba - + theta = (done+sm%cf_a)/2 delta = (done-sm%cf_a)/2 sigma = theta/delta @@ -232,21 +224,15 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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) - if (do_timings) call psb_tic(poly_vect) call psb_geaxpby((done/sm%rho_ba),ty,dzero,r,desc_data,info) - !write(0,*) 'POLY_NEW Iteration',0,' :',psb_genrm2(r,desc_data,info) - if (.false.) then - call psb_geaxpby((done/theta),r,dzero,tz,desc_data,info) - call psb_geaxpby(done,tz,done,tx,desc_data,info) - else - call psb_abgdxyz((done/theta),dzero,done,done,r,tz,tx,desc_data,info) - end if + 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_) @@ -254,54 +240,16 @@ subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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) - if (do_timings) call psb_tic(poly_vect) - - !write(0,*) 'POLY_NEW Iteration',i,' :',psb_genrm2(r,desc_data,info) - ! ! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1} rho = done/(2*sigma - rho_old) - if (.false.) then - call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) - call psb_geaxpby(done,tz,done,tx,desc_data,info) - else - call psb_abgdxyz((2*rho/delta),(rho*rho_old),done,done,r,tz,tx,desc_data,info) - end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother NEW ',i,res - ! x_k = x_{k-1} + z_k - rho_old = rho + 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) - end do - end block - if (do_timings) call psb_toc(poly_3) - - case(amg_poly_dbg_) - block - real(psb_dpk_) :: sigma, theta, delta, rho_old, rho - ! b == x - ! x == tx - ! - write(0,*) 'Parameter: ',sm%cf_a - theta = (done+sm%cf_a)/2 - delta = (done-sm%cf_a)/2 - sigma = theta/delta - rho_old = done/sigma - call sm%sv%apply(done,r,dzero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') - call psb_geaxpby(done,ty,dzero,r,desc_data,info) - call psb_geaxpby(done/theta,r,dzero,tz,desc_data,info) - write(0,*) 'POLY_DBG Iteration',0,' :',psb_genrm2(r,desc_data,info) - do i=1, sm%pdegree - call psb_geaxpby(done,tz,done,tx,desc_data,info) - call psb_spmm(done,sm%pa,tz,dzero,ty,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(-(done),ty,done,r,desc_data,trans_,aux,wv(5:),info,init='Z') - write(0,*) 'POLY_DBG Iteration',i,' :',psb_genrm2(r,desc_data,info) - rho = done/(2*sigma - rho_old) - call psb_geaxpby((2*rho/delta),r,rho*rho_old,tz,desc_data,info) 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,& diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 index 77b1aa3d..dd156912 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_bld.f90 @@ -87,14 +87,10 @@ subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold) & a_err='invalid sm%degree for poly_beta') goto 9999 end if - case(amg_poly_new_, amg_poly_dbg_) + case(amg_poly_new_) if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then !Ok -!!$ write(0,*) 'Vector: ' -!!$ do i=1,size(amg_d_poly_a_vect) -!!$ write(0,*) i,amg_d_poly_a_vect(i) -!!$ end do sm%cf_a = amg_d_poly_a_vect(sm%pdegree) else info = psb_err_internal_error_ diff --git a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 index 5d8d1169..916fb5e6 100644 --- a/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 +++ b/amgprec/impl/smoother/amg_d_poly_smoother_cseti.f90 @@ -58,7 +58,7 @@ subroutine amg_d_poly_smoother_cseti(sm,what,val,info,idx) sm%pdegree = val case('POLY_VARIANT') select case(val) - case(amg_poly_lottes_,amg_poly_lottes_beta_,amg_poly_new_,amg_poly_dbg_) + 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 diff --git a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 index fca259ff..de05bedb 100644 --- a/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 +++ b/amgprec/impl/smoother/amg_s_poly_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,wv,info,init,initu) + & sweeps,work,wv,info,init,initu) use psb_base_mod use amg_s_diag_solver @@ -55,6 +55,10 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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 @@ -92,7 +96,19 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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() @@ -125,38 +141,39 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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 + do i=1, sm%pdegree-1 ! B r_{k-1} - call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z') + 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 (.false.) then - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(sone,tz,sone,tx,desc_data,info) - else - call psb_abgdxyz(cr,cz,sone,sone,ty,tz,tx,desc_data,info) - end if - if (.false.) then - call psb_geaxpby(sone,x,szero,r,desc_data,info) - call psb_spmm(-sone,sm%pa,tx,sone,r,desc_data,info,work=aux,trans=trans_) - else - call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_) - end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother LOTTES',i,res - ! x_k = x_{k-1} + z_k + 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 @@ -170,32 +187,30 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& sm%poly_beta(1:sm%pdegree) = amg_d_poly_beta_mat(1:sm%pdegree,sm%pdegree) end if - do i=1, sm%pdegree + 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 (.false.) then - ! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1} - call psb_geaxpby(cr,ty,cz,tz,desc_data,info) - ! r_k = b-Ax_k = x -A tx - call psb_geaxpby(sm%poly_beta(i),tz,sone,tx,desc_data,info) - else - call psb_abgdxyz(cr,cz,sm%poly_beta(i),sone,ty,tz,tx,desc_data,info) - end if - if (.false.) then - call psb_geaxpby(sone,x,szero,r,desc_data,info) - call psb_spmm(-sone,sm%pa,tx,sone,r,desc_data,info,work=aux,trans=trans_) - else - call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_) - end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother LOTTES_BETA',i,res - ! x_k = x_{k-1} + z_k + 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 @@ -206,40 +221,35 @@ subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& 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 (.false.) then - call psb_geaxpby((sone/theta),r,szero,tz,desc_data,info) - call psb_geaxpby(sone,tz,sone,tx,desc_data,info) - else - call psb_abgdxyz((sone/theta),szero,sone,sone,r,tz,tx,desc_data,info) - end if + 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 (.false.) then - call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info) - call psb_geaxpby(sone,tz,sone,tx,desc_data,info) - else - call psb_abgdxyz((2*rho/delta),(rho*rho_old),sone,sone,r,tz,tx,desc_data,info) - end if -!!$ res = psb_genrm2(r,desc_data,info) -!!$ write(0,*) 'Polynomial smoother NEW ',i,res - ! x_k = x_{k-1} + z_k + 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,& From a17f503486f6c1c00aea684132c74f89cf227ebb Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Fri, 26 Apr 2024 10:54:43 +0000 Subject: [PATCH 30/51] First hardcoded implementation of l1 smooth aggregation --- .../impl/aggregator/amg_daggrmat_smth_bld.f90 | 37 +++++++++++++++---- 1 file changed, 29 insertions(+), 8 deletions(-) diff --git a/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 b/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 index d365bf27..2b9b1ea7 100644 --- a/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 +++ b/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 @@ -112,11 +112,11 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& implicit none ! Arguments - type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) - type(amg_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr + type(amg_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr type(psb_ldspmat_type), intent(inout) :: t_prol type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info @@ -132,7 +132,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_d_coo_sparse_mat) :: coo_prol, coo_restr type(psb_d_csr_sparse_mat) :: acsr1, acsrf, csr_prol, acsr real(psb_dpk_), allocatable :: adiag(:) - real(psb_dpk_), allocatable :: arwsum(:) + real(psb_dpk_), allocatable :: arwsum(:),l1rwsum(:) integer(psb_ipk_) :: ierr(5) logical :: filter_mat integer(psb_ipk_) :: debug_level, debug_unit, err_act @@ -141,6 +141,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& logical, parameter :: debug_new=.false. character(len=80) :: filename logical, parameter :: do_timings=.false. + logical, parameter :: do_l1correction=.true. integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1 integer(psb_ipk_), save :: idx_phase3=-1, idx_cdasb=-1, idx_ptap=-1 @@ -200,6 +201,21 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) if (info == psb_success_) call a%cp_to(acsr) + ! Get the l1-diagonal of D + if (do_l1correction) then + allocate(l1rwsum(nrow)) + call acsr%arwsum(l1rwsum) + if (info == psb_success_) & + & call psb_realloc(ncol,l1rwsum,info) + if (info == psb_success_) & + & call psb_halo(l1rwsum,desc_a,info) + ! \tilde{D}_{i,i} = \sum_{j \ne i} |a_{i,j}| + !$OMP parallel do private(i) schedule(static) + do i=1,size(adiag) + adiag(i) = adiag(i) + l1rwsum(i) - abs(adiag(i)) + end do + !$OMP end parallel do + end if if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') @@ -230,7 +246,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& enddo if (jd == -1) then - write(0,*) 'Wrong input: we need the diagonal!!!!', i + if (.not.do_l1correction) write(0,*) 'Wrong input: we need the diagonal!!!!', i else acsrf%val(jd)=acsrf%val(jd)-tmp end if @@ -240,7 +256,6 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& call acsrf%clean_zeros(info) end if - !$OMP parallel do private(i) schedule(static) do i=1,size(adiag) if (adiag(i) /= dzero) then @@ -249,7 +264,8 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& adiag(i) = done end if end do - !$OMP end parallel do + !$OMP end parallel do + if (parms%aggr_omega_alg == amg_eig_est_) then if (parms%aggr_eig == amg_max_norm_) then @@ -259,7 +275,9 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& call psb_amx(ctxt,anorm) omega = 4.d0/(3.d0*anorm) parms%aggr_omega_val = omega - + else if (do_l1correction) then + ! For l1-Jacobi this can be estimated with 1 + parms%aggr_omega_val = done else info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid amg_aggr_eig_') @@ -323,6 +341,9 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& & write(debug_unit,*) me,' ',trim(name),& & 'Done smooth_aggregate ' call psb_erractionrestore(err_act) + + if (allocated(l1rwsum)) deallocate(l1rwsum) + if (allocated(arwsum)) deallocate(arwsum) return 9999 continue From 5790aa0cbd5aa5235bbae6742f30f738ff77b687 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Fri, 26 Apr 2024 10:55:47 +0000 Subject: [PATCH 31/51] Revert "First hardcoded implementation of l1 smooth aggregation" This reverts commit a17f503486f6c1c00aea684132c74f89cf227ebb. --- .../impl/aggregator/amg_daggrmat_smth_bld.f90 | 37 ++++--------------- 1 file changed, 8 insertions(+), 29 deletions(-) diff --git a/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 b/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 index 2b9b1ea7..d365bf27 100644 --- a/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 +++ b/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 @@ -112,11 +112,11 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& implicit none ! Arguments - type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) - type(amg_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr + type(amg_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr type(psb_ldspmat_type), intent(inout) :: t_prol type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info @@ -132,7 +132,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_d_coo_sparse_mat) :: coo_prol, coo_restr type(psb_d_csr_sparse_mat) :: acsr1, acsrf, csr_prol, acsr real(psb_dpk_), allocatable :: adiag(:) - real(psb_dpk_), allocatable :: arwsum(:),l1rwsum(:) + real(psb_dpk_), allocatable :: arwsum(:) integer(psb_ipk_) :: ierr(5) logical :: filter_mat integer(psb_ipk_) :: debug_level, debug_unit, err_act @@ -141,7 +141,6 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& logical, parameter :: debug_new=.false. character(len=80) :: filename logical, parameter :: do_timings=.false. - logical, parameter :: do_l1correction=.true. integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1 integer(psb_ipk_), save :: idx_phase3=-1, idx_cdasb=-1, idx_ptap=-1 @@ -201,21 +200,6 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) if (info == psb_success_) call a%cp_to(acsr) - ! Get the l1-diagonal of D - if (do_l1correction) then - allocate(l1rwsum(nrow)) - call acsr%arwsum(l1rwsum) - if (info == psb_success_) & - & call psb_realloc(ncol,l1rwsum,info) - if (info == psb_success_) & - & call psb_halo(l1rwsum,desc_a,info) - ! \tilde{D}_{i,i} = \sum_{j \ne i} |a_{i,j}| - !$OMP parallel do private(i) schedule(static) - do i=1,size(adiag) - adiag(i) = adiag(i) + l1rwsum(i) - abs(adiag(i)) - end do - !$OMP end parallel do - end if if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') @@ -246,7 +230,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& enddo if (jd == -1) then - if (.not.do_l1correction) write(0,*) 'Wrong input: we need the diagonal!!!!', i + write(0,*) 'Wrong input: we need the diagonal!!!!', i else acsrf%val(jd)=acsrf%val(jd)-tmp end if @@ -256,6 +240,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& call acsrf%clean_zeros(info) end if + !$OMP parallel do private(i) schedule(static) do i=1,size(adiag) if (adiag(i) /= dzero) then @@ -264,8 +249,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& adiag(i) = done end if end do - !$OMP end parallel do - + !$OMP end parallel do if (parms%aggr_omega_alg == amg_eig_est_) then if (parms%aggr_eig == amg_max_norm_) then @@ -275,9 +259,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& call psb_amx(ctxt,anorm) omega = 4.d0/(3.d0*anorm) parms%aggr_omega_val = omega - else if (do_l1correction) then - ! For l1-Jacobi this can be estimated with 1 - parms%aggr_omega_val = done + else info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid amg_aggr_eig_') @@ -341,9 +323,6 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& & write(debug_unit,*) me,' ',trim(name),& & 'Done smooth_aggregate ' call psb_erractionrestore(err_act) - - if (allocated(l1rwsum)) deallocate(l1rwsum) - if (allocated(arwsum)) deallocate(arwsum) return 9999 continue From 3e3b3431316558de0fa69d4e7b0af15574363744 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 10 May 2024 15:02:36 +0200 Subject: [PATCH 32/51] Fix potential overflow issue in SOC_MAP_BLD --- amgprec/impl/aggregator/amg_c_soc1_map_bld.F90 | 3 ++- amgprec/impl/aggregator/amg_c_soc2_map_bld.F90 | 3 ++- amgprec/impl/aggregator/amg_d_soc1_map_bld.F90 | 3 ++- amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 | 3 ++- amgprec/impl/aggregator/amg_s_soc1_map_bld.F90 | 3 ++- amgprec/impl/aggregator/amg_s_soc2_map_bld.F90 | 3 ++- amgprec/impl/aggregator/amg_z_soc1_map_bld.F90 | 3 ++- amgprec/impl/aggregator/amg_z_soc2_map_bld.F90 | 3 ++- 8 files changed, 16 insertions(+), 8 deletions(-) diff --git a/amgprec/impl/aggregator/amg_c_soc1_map_bld.F90 b/amgprec/impl/aggregator/amg_c_soc1_map_bld.F90 index 53892ebc..24720675 100644 --- a/amgprec/impl/aggregator/amg_c_soc1_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_c_soc1_map_bld.F90 @@ -275,7 +275,8 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) if (disjoint) then locnaggr(kk) = locnaggr(kk) + 1 - itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk + itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow + itmp = itmp*nths+kk if (itmp < (bnds(kk)-1+locnaggr(kk))) then !$omp atomic update info = max(12345678,info) diff --git a/amgprec/impl/aggregator/amg_c_soc2_map_bld.F90 b/amgprec/impl/aggregator/amg_c_soc2_map_bld.F90 index b250e434..57ed8893 100644 --- a/amgprec/impl/aggregator/amg_c_soc2_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_c_soc2_map_bld.F90 @@ -309,7 +309,8 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in ! if (disjoint) then locnaggr(kk) = locnaggr(kk) + 1 - itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk + itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow + itmp = itmp*nths+kk if (itmp < (bnds(kk)-1+locnaggr(kk))) then !$omp atomic update info = max(12345678,info) diff --git a/amgprec/impl/aggregator/amg_d_soc1_map_bld.F90 b/amgprec/impl/aggregator/amg_d_soc1_map_bld.F90 index fba80c10..200d630c 100644 --- a/amgprec/impl/aggregator/amg_d_soc1_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_d_soc1_map_bld.F90 @@ -275,7 +275,8 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) if (disjoint) then locnaggr(kk) = locnaggr(kk) + 1 - itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk + itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow + itmp = itmp*nths+kk if (itmp < (bnds(kk)-1+locnaggr(kk))) then !$omp atomic update info = max(12345678,info) diff --git a/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 b/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 index 345cd1ad..e2b7ea0c 100644 --- a/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_d_soc2_map_bld.F90 @@ -309,7 +309,8 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in ! if (disjoint) then locnaggr(kk) = locnaggr(kk) + 1 - itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk + itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow + itmp = itmp*nths+kk if (itmp < (bnds(kk)-1+locnaggr(kk))) then !$omp atomic update info = max(12345678,info) diff --git a/amgprec/impl/aggregator/amg_s_soc1_map_bld.F90 b/amgprec/impl/aggregator/amg_s_soc1_map_bld.F90 index 857c6ff3..0f8bb7dd 100644 --- a/amgprec/impl/aggregator/amg_s_soc1_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_s_soc1_map_bld.F90 @@ -275,7 +275,8 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) if (disjoint) then locnaggr(kk) = locnaggr(kk) + 1 - itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk + itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow + itmp = itmp*nths+kk if (itmp < (bnds(kk)-1+locnaggr(kk))) then !$omp atomic update info = max(12345678,info) diff --git a/amgprec/impl/aggregator/amg_s_soc2_map_bld.F90 b/amgprec/impl/aggregator/amg_s_soc2_map_bld.F90 index ef7f5707..99047468 100644 --- a/amgprec/impl/aggregator/amg_s_soc2_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_s_soc2_map_bld.F90 @@ -309,7 +309,8 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in ! if (disjoint) then locnaggr(kk) = locnaggr(kk) + 1 - itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk + itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow + itmp = itmp*nths+kk if (itmp < (bnds(kk)-1+locnaggr(kk))) then !$omp atomic update info = max(12345678,info) diff --git a/amgprec/impl/aggregator/amg_z_soc1_map_bld.F90 b/amgprec/impl/aggregator/amg_z_soc1_map_bld.F90 index 50fe70a2..7961921a 100644 --- a/amgprec/impl/aggregator/amg_z_soc1_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_z_soc1_map_bld.F90 @@ -275,7 +275,8 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0) if (disjoint) then locnaggr(kk) = locnaggr(kk) + 1 - itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk + itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow + itmp = itmp*nths+kk if (itmp < (bnds(kk)-1+locnaggr(kk))) then !$omp atomic update info = max(12345678,info) diff --git a/amgprec/impl/aggregator/amg_z_soc2_map_bld.F90 b/amgprec/impl/aggregator/amg_z_soc2_map_bld.F90 index c6ac226e..35d02fd0 100644 --- a/amgprec/impl/aggregator/amg_z_soc2_map_bld.F90 +++ b/amgprec/impl/aggregator/amg_z_soc2_map_bld.F90 @@ -309,7 +309,8 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in ! if (disjoint) then locnaggr(kk) = locnaggr(kk) + 1 - itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk + itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow + itmp = itmp*nths+kk if (itmp < (bnds(kk)-1+locnaggr(kk))) then !$omp atomic update info = max(12345678,info) From ab5eaac5ed5b6bd9dc4db7dc1d8cd2f0552fc95e Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 30 May 2024 08:12:48 -0400 Subject: [PATCH 33/51] Cosmetic changes --- ...mEdgesLinearSearchMesgBndlSmallMateCMP.cpp | 21 ++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp index b086edad..b758dc69 100644 --- a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp +++ b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp @@ -126,8 +126,10 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( fflush(stdout); #endif - MilanLongInt StartIndex = verDistance[myRank]; // The starting vertex owned by the current rank - MilanLongInt EndIndex = verDistance[myRank + 1] - 1; // The ending vertex owned by the current rank + // 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; @@ -145,7 +147,8 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( // only one message will be sent in the initialization phase - // one of: REQUEST/FAILURE/SUCCESS vector QLocalVtx, QGhostVtx, QMsgType; - vector QOwner; // Changed by Fabio to be an integer, addresses needs to be integers! + // 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++) @@ -153,7 +156,8 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( MilanLongInt NumMessagesBundled = 0; // TODO when the last computational section will be refactored this could be eliminated - MilanInt ghostOwner = 0; // Changed by Fabio to be an integer, addresses needs to be integers! + // 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; @@ -168,9 +172,12 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( MilanLongInt myCard = 0; // Build the Ghost Vertex Set: Vg - map Ghost2LocalMap; // Map each ghost vertex to a local vertex - vector Counter; // Store the edge count for each ghost vertex - MilanLongInt numGhostVertices = 0, numGhostEdges = 0; // Number of Ghost vertices + // 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..."; From 897c5229a624024fb5307f547456c07e581b0fd3 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 30 May 2024 08:13:08 -0400 Subject: [PATCH 34/51] Improve behaviour of OpenMP matching --- .../impl/aggregator/processExposedVertex.cpp | 51 ++++++++++--------- amgprec/impl/aggregator/queueTransfer.cpp | 3 +- 2 files changed, 28 insertions(+), 26 deletions(-) diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index c7ac4703..81ce23eb 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -113,32 +113,35 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, } // End of if(w >=0) else { - // This piece of code is executed a really small amount 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 - +#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); + 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); - 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 + (*msgInd)++; + (*NumMessagesBundled)++; + ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs); + // assert(ghostOwner != -1); + // assert(ghostOwner != myRank); + 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) diff --git a/amgprec/impl/aggregator/queueTransfer.cpp b/amgprec/impl/aggregator/queueTransfer.cpp index e51095da..64a60157 100644 --- a/amgprec/impl/aggregator/queueTransfer.cpp +++ b/amgprec/impl/aggregator/queueTransfer.cpp @@ -17,8 +17,6 @@ void queuesTransfer(vector &U, U.insert(U.end(), privateU.begin(), privateU.end()); } - privateU.clear(); - #pragma omp critical(sendMessageTransfer) { @@ -28,6 +26,7 @@ void queuesTransfer(vector &U, QOwner.insert(QOwner.end(), privateQOwner.begin(), privateQOwner.end()); } + privateU.clear(); privateQLocalVtx.clear(); privateQGhostVtx.clear(); privateQMsgType.clear(); From fb802c62cd51624ee16130cf8d7c42b76a8c7c95 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 30 May 2024 17:25:25 +0200 Subject: [PATCH 35/51] Merge PSBCXXDEFINES into AMGCXXDEFINES --- Make.inc.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Make.inc.in b/Make.inc.in index 3638f486..9ac10ee7 100644 --- a/Make.inc.in +++ b/Make.inc.in @@ -75,7 +75,7 @@ CDEFINES=$(AMGCDEFINES) AMGFDEFINES=@AMGFDEFINES@ $(PSBFDEFINES) FDEFINES=$(AMGFDEFINES) -CXXDEFINES=@AMGCXXDEFINES@ +CXXDEFINES=@AMGCXXDEFINES@ $(PSBCXXDEFINES) @COMPILERULES@ From 13eee99ea33edb44c1ddcb2ce47932864547a5b5 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 30 May 2024 17:26:34 +0200 Subject: [PATCH 36/51] Use ifdef OPENMP --- amgprec/impl/aggregator/MatchBoxPC.cpp | 2 +- amgprec/impl/aggregator/MatchBoxPC.h | 6 +++--- ...stEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp | 2 +- amgprec/impl/aggregator/clean.cpp | 2 +- amgprec/impl/aggregator/computeCandidateMate.cpp | 2 +- amgprec/impl/aggregator/extractUChunk.cpp | 2 +- amgprec/impl/aggregator/findOwnerOfGhost.cpp | 2 +- amgprec/impl/aggregator/initialize.cpp | 2 +- amgprec/impl/aggregator/isAlreadyMatched.cpp | 2 +- amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp | 2 +- amgprec/impl/aggregator/processCrossEdge.cpp | 2 +- amgprec/impl/aggregator/processExposedVertex.cpp | 2 +- .../aggregator/processMatchedVerticesAndSendMessages.cpp | 2 +- amgprec/impl/aggregator/processMessages.cpp | 2 +- amgprec/impl/aggregator/queueTransfer.cpp | 2 +- amgprec/impl/aggregator/sendBundledMessages.cpp | 2 +- 16 files changed, 18 insertions(+), 18 deletions(-) diff --git a/amgprec/impl/aggregator/MatchBoxPC.cpp b/amgprec/impl/aggregator/MatchBoxPC.cpp index 37a879be..146e8aa1 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.cpp +++ b/amgprec/impl/aggregator/MatchBoxPC.cpp @@ -73,7 +73,7 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge, #endif // Rimosso per tornare al vecchio matching #define OMP -#ifdef OMP +#ifdef OPENMP fprintf(stderr,"Warning: using buggy OpenMP matching!\n"); dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge, verLocPtr, verLocInd, edgeLocWeight, diff --git a/amgprec/impl/aggregator/MatchBoxPC.h b/amgprec/impl/aggregator/MatchBoxPC.h index 35cab21d..24fd3134 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.h +++ b/amgprec/impl/aggregator/MatchBoxPC.h @@ -59,7 +59,7 @@ #include #include #include -#ifdef OMP +#ifdef OPENMP // OpenMP is included and used if and only if the OpenMP version of the matching // is required #include "omp.h" @@ -178,7 +178,7 @@ extern "C" #define MilanRealMin MINUS_INFINITY #endif -#ifdef OMP +#ifdef OPENMP /* These functions are only used in the experimental OMP implementation, if that is disabled there is no reason to actually compile or reference them. */ @@ -431,7 +431,7 @@ is disabled there is no reason to actually compile or reference them. */ #endif -#ifndef OMP +#ifndef OPENMP //Function of find the owner of a ghost vertex using binary search: inline MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance, MilanInt myRank, MilanInt numProcs); diff --git a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp index b086edad..7e332cef 100644 --- a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp +++ b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP // *********************************************************************** // // MatchboxP: A C++ library for approximate weighted matching diff --git a/amgprec/impl/aggregator/clean.cpp b/amgprec/impl/aggregator/clean.cpp index 018469e4..479dcce3 100644 --- a/amgprec/impl/aggregator/clean.cpp +++ b/amgprec/impl/aggregator/clean.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP // TODO comment void clean(MilanLongInt NLVer, diff --git a/amgprec/impl/aggregator/computeCandidateMate.cpp b/amgprec/impl/aggregator/computeCandidateMate.cpp index 39ce8db1..f70b8866 100644 --- a/amgprec/impl/aggregator/computeCandidateMate.cpp +++ b/amgprec/impl/aggregator/computeCandidateMate.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP /** * Execute the research fr the Candidate Mate without controlling if the vertices are already matched. * Returns the vertices with the highest weight diff --git a/amgprec/impl/aggregator/extractUChunk.cpp b/amgprec/impl/aggregator/extractUChunk.cpp index 0986dfb6..4e50a4f3 100644 --- a/amgprec/impl/aggregator/extractUChunk.cpp +++ b/amgprec/impl/aggregator/extractUChunk.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP void extractUChunk( vector &UChunkBeingProcessed, vector &U, diff --git a/amgprec/impl/aggregator/findOwnerOfGhost.cpp b/amgprec/impl/aggregator/findOwnerOfGhost.cpp index 81c18822..2723a7a3 100644 --- a/amgprec/impl/aggregator/findOwnerOfGhost.cpp +++ b/amgprec/impl/aggregator/findOwnerOfGhost.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP /// 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 3f0f1a10..2c8f052d 100644 --- a/amgprec/impl/aggregator/initialize.cpp +++ b/amgprec/impl/aggregator/initialize.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP void initialize(MilanLongInt NLVer, MilanLongInt NLEdge, MilanLongInt StartIndex, MilanLongInt EndIndex, MilanLongInt *numGhostEdges, diff --git a/amgprec/impl/aggregator/isAlreadyMatched.cpp b/amgprec/impl/aggregator/isAlreadyMatched.cpp index de5f2f18..16d47a14 100644 --- a/amgprec/impl/aggregator/isAlreadyMatched.cpp +++ b/amgprec/impl/aggregator/isAlreadyMatched.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP /** * //TODO documentation * @param k diff --git a/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp b/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp index f5429bf4..79f253eb 100644 --- a/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp +++ b/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer, MilanLongInt *verLocPtr, MilanLongInt *verLocInd, diff --git a/amgprec/impl/aggregator/processCrossEdge.cpp b/amgprec/impl/aggregator/processCrossEdge.cpp index d7c72d42..45cddb44 100644 --- a/amgprec/impl/aggregator/processCrossEdge.cpp +++ b/amgprec/impl/aggregator/processCrossEdge.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP void PROCESS_CROSS_EDGE(MilanLongInt *edge, MilanLongInt *S) { diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index c7ac4703..ba07425a 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, MilanLongInt *candidateMate, MilanLongInt *verLocInd, diff --git a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp index 4a9cfcba..e02dd9c7 100644 --- a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp +++ b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP //#define DEBUG_HANG_ void processMatchedVerticesAndSendMessages( MilanLongInt NLVer, diff --git a/amgprec/impl/aggregator/processMessages.cpp b/amgprec/impl/aggregator/processMessages.cpp index 6ac3f541..dc09cde1 100644 --- a/amgprec/impl/aggregator/processMessages.cpp +++ b/amgprec/impl/aggregator/processMessages.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP //#define DEBUG_HANG_ void processMessages( diff --git a/amgprec/impl/aggregator/queueTransfer.cpp b/amgprec/impl/aggregator/queueTransfer.cpp index e51095da..51989f34 100644 --- a/amgprec/impl/aggregator/queueTransfer.cpp +++ b/amgprec/impl/aggregator/queueTransfer.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#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 919dc7e9..3349ce86 100644 --- a/amgprec/impl/aggregator/sendBundledMessages.cpp +++ b/amgprec/impl/aggregator/sendBundledMessages.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP void sendBundledMessages(MilanLongInt *numGhostEdges, MilanInt *BufferSize, MilanLongInt *Buffer, From 67594f8b07c5d7547af166c5040f779fc8b37b1c Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 30 May 2024 17:35:15 +0200 Subject: [PATCH 37/51] Fixes for OpenMP --- amgprec/impl/aggregator/MatchBoxPC.cpp | 2 +- amgprec/impl/aggregator/processMatchedVertices.cpp | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/amgprec/impl/aggregator/MatchBoxPC.cpp b/amgprec/impl/aggregator/MatchBoxPC.cpp index 146e8aa1..a43fb2f5 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.cpp +++ b/amgprec/impl/aggregator/MatchBoxPC.cpp @@ -74,7 +74,7 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge, // Rimosso per tornare al vecchio matching #define OMP #ifdef OPENMP - fprintf(stderr,"Warning: using buggy OpenMP matching!\n"); + //fprintf(stderr,"Warning: using buggy OpenMP matching!\n"); dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge, verLocPtr, verLocInd, edgeLocWeight, verDistance, Mate, diff --git a/amgprec/impl/aggregator/processMatchedVertices.cpp b/amgprec/impl/aggregator/processMatchedVertices.cpp index d88199a6..77ec34bb 100644 --- a/amgprec/impl/aggregator/processMatchedVertices.cpp +++ b/amgprec/impl/aggregator/processMatchedVertices.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OMP +#ifdef OPENMP void processMatchedVertices( MilanLongInt NLVer, vector &UChunkBeingProcessed, From bd2d1e3b2600842bdc5937c37bcd685b15994c8f Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 4 Jun 2024 16:53:52 +0200 Subject: [PATCH 38/51] Additional OpenMP tinkering in matchboxp --- .../impl/aggregator/processExposedVertex.cpp | 109 ++++++++---------- amgprec/impl/aggregator/queueTransfer.cpp | 6 +- 2 files changed, 49 insertions(+), 66 deletions(-) diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index 81ce23eb..915c0ead 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -62,58 +62,41 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, fflush(stdout); #endif // If found a dominating edge: - if (w >= 0) - { - -#pragma omp critical(processExposed) - { - if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap)) { - w = computeCandidateMate(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 - + if (w >= 0) { +#pragma omp critical(Matching) + { + if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap)) { + w = computeCandidateMate(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); + 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 critical processExposed - + } // 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) + //#pragma omp critical(adjuse) { // This piece of code is executed a really small number of times adj11 = verLocPtr[v]; @@ -132,6 +115,7 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs); // assert(ghostOwner != -1); // assert(ghostOwner != myRank); +#pragma omp atomic PCounter[ghostOwner]++; privateQLocalVtx.push_back(v + StartIndex); @@ -144,23 +128,23 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, } } // End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v) - + switch (option) - { - case -1: + { + case -1: break; - case 1: + 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: + 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; @@ -171,29 +155,30 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, 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: + 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/queueTransfer.cpp b/amgprec/impl/aggregator/queueTransfer.cpp index 64a60157..67a2e524 100644 --- a/amgprec/impl/aggregator/queueTransfer.cpp +++ b/amgprec/impl/aggregator/queueTransfer.cpp @@ -15,11 +15,9 @@ void queuesTransfer(vector &U, #pragma omp critical(U) { U.insert(U.end(), privateU.begin(), privateU.end()); - } - -#pragma omp critical(sendMessageTransfer) - { + //#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()); From e11a134a1fe9d9c5065c94fb2478b4ee749f904b Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 4 Jun 2024 17:39:31 +0200 Subject: [PATCH 39/51] Additional tinkering with OpenMP matchbox --- .../aggregator/processMatchedVertices.cpp | 96 ++++++++-------- .../processMatchedVerticesAndSendMessages.cpp | 106 ++++++++---------- 2 files changed, 93 insertions(+), 109 deletions(-) diff --git a/amgprec/impl/aggregator/processMatchedVertices.cpp b/amgprec/impl/aggregator/processMatchedVertices.cpp index 77ec34bb..457e0de8 100644 --- a/amgprec/impl/aggregator/processMatchedVertices.cpp +++ b/amgprec/impl/aggregator/processMatchedVertices.cpp @@ -91,57 +91,57 @@ void processMatchedVertices( if (mateVal < 0) { #pragma omp critical { - if (candidateMate[v - StartIndex] == u) { +#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 = computeCandidateMate(verLocPtr[v - StartIndex], - verLocPtr[v - StartIndex + 1], - edgeLocWeight, 0, - verLocInd, - StartIndex, - EndIndex, - GMate, - Mate, - Ghost2LocalMap); - - candidateMate[v - StartIndex] = w; - + w = computeCandidateMate(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: @@ -179,6 +179,7 @@ void processMatchedVertices( ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs); // assert(ghostOwner != -1); // assert(ghostOwner != myRank); +#pragma omp atomic PCounter[ghostOwner]++; (*NumMessagesBundled)++; (*msgInd)++; @@ -211,7 +212,7 @@ void processMatchedVertices( ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs); // assert(ghostOwner != -1); // assert(ghostOwner != myRank); - +#pragma omp atomic PCounter[ghostOwner]++; (*NumMessagesBundled)++; (*msgInd)++; @@ -248,7 +249,6 @@ void processMatchedVertices( break; } // End of switch - } // End of inner for } } // End of outer for @@ -265,17 +265,15 @@ void processMatchedVertices( U.insert(U.end(), privateU.begin(), privateU.end()); } - privateU.clear(); - #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(); diff --git a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp index e02dd9c7..e75fa8db 100644 --- a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp +++ b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp @@ -77,7 +77,6 @@ void processMatchedVerticesAndSendMessages( #ifdef COUNT_LOCAL_VERTEX localVertices++; #endif - // Get the Adjacency list for u adj1 = verLocPtr[u - StartIndex]; // Pointer adj2 = verLocPtr[u - StartIndex + 1]; @@ -97,58 +96,57 @@ 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 = computeCandidateMate(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: @@ -211,15 +209,12 @@ 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 @@ -229,7 +224,6 @@ void processMatchedVerticesAndSendMessages( (*msgActual)++; (*msgInd)++; - privateQLocalVtx.push_back(v); privateQGhostVtx.push_back(w); privateQMsgType.push_back(FAILURE); @@ -248,17 +242,14 @@ void processMatchedVerticesAndSendMessages( #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); @@ -281,10 +272,7 @@ void processMatchedVerticesAndSendMessages( #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 @@ -293,12 +281,10 @@ void processMatchedVerticesAndSendMessages( cout << myRank<<" Sending: "<(), ghostOwner, ComputeTag, comm); //cout << myRank<<" Sending to "<(), ghostOwner, ComputeTag, comm); From cfbec1f6ea2534f020d90edd00f415b5dd1ee684 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 5 Jun 2024 10:38:30 +0200 Subject: [PATCH 40/51] Cosmetic changes to MatchBoxPC --- amgprec/impl/aggregator/MatchBoxPC.cpp | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/amgprec/impl/aggregator/MatchBoxPC.cpp b/amgprec/impl/aggregator/MatchBoxPC.cpp index a43fb2f5..aa2658ea 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.cpp +++ b/amgprec/impl/aggregator/MatchBoxPC.cpp @@ -72,8 +72,7 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge, double tmr = MPI_Wtime(); #endif -// Rimosso per tornare al vecchio matching #define OMP -#ifdef OPENMP +#if defined(OPENMP) //fprintf(stderr,"Warning: using buggy OpenMP matching!\n"); dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge, verLocPtr, verLocInd, edgeLocWeight, From 02a83575a2580c8c5cac4a63a4587be840bb910e Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 5 Jun 2024 13:11:41 +0200 Subject: [PATCH 41/51] Reorganize MatchBox (prepare for S OpenMP) --- amgprec/impl/aggregator/MatchBoxPC.cpp | 3 +- amgprec/impl/aggregator/MatchBoxPC.h | 499 +++++++++--------- ...mEdgesLinearSearchMesgBndlSmallMateCMP.cpp | 10 +- amgprec/impl/aggregator/clean.cpp | 2 - .../impl/aggregator/computeCandidateMate.cpp | 6 +- amgprec/impl/aggregator/extractUChunk.cpp | 2 - amgprec/impl/aggregator/findOwnerOfGhost.cpp | 2 - amgprec/impl/aggregator/initialize.cpp | 2 - amgprec/impl/aggregator/isAlreadyMatched.cpp | 2 - .../parallelComputeCandidateMateB.cpp | 7 +- amgprec/impl/aggregator/processCrossEdge.cpp | 2 - .../impl/aggregator/processExposedVertex.cpp | 6 +- .../aggregator/processMatchedVertices.cpp | 6 +- .../processMatchedVerticesAndSendMessages.cpp | 6 +- amgprec/impl/aggregator/processMessages.cpp | 6 +- amgprec/impl/aggregator/queueTransfer.cpp | 2 - .../impl/aggregator/sendBundledMessages.cpp | 2 - 17 files changed, 265 insertions(+), 300 deletions(-) diff --git a/amgprec/impl/aggregator/MatchBoxPC.cpp b/amgprec/impl/aggregator/MatchBoxPC.cpp index aa2658ea..65a910b1 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.cpp +++ b/amgprec/impl/aggregator/MatchBoxPC.cpp @@ -72,7 +72,8 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge, double tmr = MPI_Wtime(); #endif -#if defined(OPENMP) +#if 1 + // defined(OPENMP) //fprintf(stderr,"Warning: using buggy OpenMP matching!\n"); dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge, verLocPtr, verLocInd, edgeLocWeight, diff --git a/amgprec/impl/aggregator/MatchBoxPC.h b/amgprec/impl/aggregator/MatchBoxPC.h index 24fd3134..4214993e 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.h +++ b/amgprec/impl/aggregator/MatchBoxPC.h @@ -178,264 +178,257 @@ extern "C" #define MilanRealMin MINUS_INFINITY #endif -#ifdef OPENMP /* 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 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); -#endif + // 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_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 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); + + 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); -#ifndef OPENMP - //Function of find the owner of a ghost vertex using binary search: - inline MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance, - MilanInt myRank, MilanInt numProcs); -#endif void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC( MilanLongInt NLVer, MilanLongInt NLEdge, diff --git a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp index 668ed626..c9199ea5 100644 --- a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp +++ b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP // *********************************************************************** // // MatchboxP: A C++ library for approximate weighted matching @@ -244,7 +243,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( * PARALLEL_COMPUTE_CANDIDATE_MATE_B is now totally parallel. */ - PARALLEL_COMPUTE_CANDIDATE_MATE_B(NLVer, + PARALLEL_COMPUTE_CANDIDATE_MATE_BD(NLVer, verLocPtr, verLocInd, myRank, @@ -321,7 +320,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( vector 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, @@ -491,7 +490,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( /////////////////////////// PROCESS MESSAGES ////////////////////////////////////// /////////////////////////////////////////////////////////////////////////////////// - processMessages(NLVer, + processMessagesD(NLVer, Mate, candidateMate, Ghost2LocalMap, @@ -559,4 +558,3 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( #endif #endif -#endif diff --git a/amgprec/impl/aggregator/clean.cpp b/amgprec/impl/aggregator/clean.cpp index 479dcce3..5a3bed01 100644 --- a/amgprec/impl/aggregator/clean.cpp +++ b/amgprec/impl/aggregator/clean.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP // TODO comment void clean(MilanLongInt NLVer, @@ -89,4 +88,3 @@ void clean(MilanLongInt NLVer, } } } -#endif diff --git a/amgprec/impl/aggregator/computeCandidateMate.cpp b/amgprec/impl/aggregator/computeCandidateMate.cpp index f70b8866..26bcbb4d 100644 --- a/amgprec/impl/aggregator/computeCandidateMate.cpp +++ b/amgprec/impl/aggregator/computeCandidateMate.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP /** * Execute the research fr the Candidate Mate without controlling if the vertices are already matched. * Returns the vertices with the highest weight @@ -9,7 +8,7 @@ * @param edgeLocWeight * @return */ -MilanLongInt firstComputeCandidateMate(MilanLongInt adj1, +MilanLongInt firstComputeCandidateMateD(MilanLongInt adj1, MilanLongInt adj2, MilanLongInt *verLocInd, MilanReal *edgeLocWeight) @@ -42,7 +41,7 @@ MilanLongInt firstComputeCandidateMate(MilanLongInt adj1, * @param Ghost2LocalMap * @return */ -MilanLongInt computeCandidateMate(MilanLongInt adj1, +MilanLongInt computeCandidateMateD(MilanLongInt adj1, MilanLongInt adj2, MilanReal *edgeLocWeight, MilanLongInt k, @@ -71,4 +70,3 @@ MilanLongInt computeCandidateMate(MilanLongInt adj1, return w; } -#endif diff --git a/amgprec/impl/aggregator/extractUChunk.cpp b/amgprec/impl/aggregator/extractUChunk.cpp index 4e50a4f3..9f5bdfe2 100644 --- a/amgprec/impl/aggregator/extractUChunk.cpp +++ b/amgprec/impl/aggregator/extractUChunk.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP void extractUChunk( vector &UChunkBeingProcessed, vector &U, @@ -29,4 +28,3 @@ void extractUChunk( } // End of critical U // End of critical U } -#endif diff --git a/amgprec/impl/aggregator/findOwnerOfGhost.cpp b/amgprec/impl/aggregator/findOwnerOfGhost.cpp index 2723a7a3..779a5e7f 100644 --- a/amgprec/impl/aggregator/findOwnerOfGhost.cpp +++ b/amgprec/impl/aggregator/findOwnerOfGhost.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP /// Find the owner of a ghost node: MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance, MilanInt myRank, MilanInt numProcs) @@ -27,4 +26,3 @@ MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance, return Current; } // End of findOwnerOfGhost() -#endif diff --git a/amgprec/impl/aggregator/initialize.cpp b/amgprec/impl/aggregator/initialize.cpp index 2c8f052d..baac9e8c 100644 --- a/amgprec/impl/aggregator/initialize.cpp +++ b/amgprec/impl/aggregator/initialize.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP void initialize(MilanLongInt NLVer, MilanLongInt NLEdge, MilanLongInt StartIndex, MilanLongInt EndIndex, MilanLongInt *numGhostEdges, @@ -302,4 +301,3 @@ void initialize(MilanLongInt NLVer, MilanLongInt NLEdge, } // End of single region } // End of parallel region } -#endif diff --git a/amgprec/impl/aggregator/isAlreadyMatched.cpp b/amgprec/impl/aggregator/isAlreadyMatched.cpp index 16d47a14..62cdca4b 100644 --- a/amgprec/impl/aggregator/isAlreadyMatched.cpp +++ b/amgprec/impl/aggregator/isAlreadyMatched.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP /** * //TODO documentation * @param k @@ -44,4 +43,3 @@ bool isAlreadyMatched(MilanLongInt node, return val >= 0; // Already matched } -#endif diff --git a/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp b/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp index 79f253eb..7576f900 100644 --- a/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp +++ b/amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp @@ -1,6 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OPENMP -void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer, +void PARALLEL_COMPUTE_CANDIDATE_MATE_BD(MilanLongInt NLVer, MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanInt myRank, @@ -20,9 +19,9 @@ 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) } } } -#endif diff --git a/amgprec/impl/aggregator/processCrossEdge.cpp b/amgprec/impl/aggregator/processCrossEdge.cpp index 45cddb44..d9d557a6 100644 --- a/amgprec/impl/aggregator/processCrossEdge.cpp +++ b/amgprec/impl/aggregator/processCrossEdge.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP void PROCESS_CROSS_EDGE(MilanLongInt *edge, MilanLongInt *S) { @@ -22,4 +21,3 @@ void PROCESS_CROSS_EDGE(MilanLongInt *edge, // End: PARALLEL_PROCESS_CROSS_EDGE_B } -#endif diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index c53af9bb..f91109ca 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -1,5 +1,4 @@ -#include "MatchBoxPC.h" -#ifdef OPENMP +#include "MatchBoxPC.h" void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, MilanLongInt *candidateMate, MilanLongInt *verLocInd, @@ -66,7 +65,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 +180,3 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, } // End of parallel region } -#endif diff --git a/amgprec/impl/aggregator/processMatchedVertices.cpp b/amgprec/impl/aggregator/processMatchedVertices.cpp index 457e0de8..62db3efc 100644 --- a/amgprec/impl/aggregator/processMatchedVertices.cpp +++ b/amgprec/impl/aggregator/processMatchedVertices.cpp @@ -1,6 +1,5 @@ #include "MatchBoxPC.h" -#ifdef OPENMP -void processMatchedVertices( +void processMatchedVerticesD( MilanLongInt NLVer, vector &UChunkBeingProcessed, vector &U, @@ -98,7 +97,7 @@ void processMatchedVertices( if (candidateMate[v - StartIndex] == u) { // Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v) - w = computeCandidateMate(verLocPtr[v - StartIndex], + w = computeCandidateMateD(verLocPtr[v - StartIndex], verLocPtr[v - StartIndex + 1], edgeLocWeight, 0, verLocInd, StartIndex, EndIndex, @@ -290,4 +289,3 @@ void processMatchedVertices( #endif } // End of parallel region } -#endif diff --git a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp index e75fa8db..09ed7ab4 100644 --- a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp +++ b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp @@ -1,7 +1,6 @@ #include "MatchBoxPC.h" -#ifdef OPENMP //#define DEBUG_HANG_ -void processMatchedVerticesAndSendMessages( +void processMatchedVerticesAndSendMessagesD( MilanLongInt NLVer, vector &UChunkBeingProcessed, vector &U, @@ -103,7 +102,7 @@ void processMatchedVerticesAndSendMessages( if (candidateMate[v - StartIndex] == u) { // Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v) - w = computeCandidateMate(verLocPtr[v - StartIndex], + w = computeCandidateMateD(verLocPtr[v - StartIndex], verLocPtr[v - StartIndex + 1], edgeLocWeight, 0, verLocInd, StartIndex, EndIndex, @@ -293,4 +292,3 @@ void processMatchedVerticesAndSendMessages( cout << myRank<<" Done sending messages"< &U, vector &privateU, vector &QLocalVtx, @@ -31,4 +30,3 @@ void queuesTransfer(vector &U, privateQOwner.clear(); } -#endif diff --git a/amgprec/impl/aggregator/sendBundledMessages.cpp b/amgprec/impl/aggregator/sendBundledMessages.cpp index 3349ce86..54736f7a 100644 --- a/amgprec/impl/aggregator/sendBundledMessages.cpp +++ b/amgprec/impl/aggregator/sendBundledMessages.cpp @@ -1,5 +1,4 @@ #include "MatchBoxPC.h" -#ifdef OPENMP void sendBundledMessages(MilanLongInt *numGhostEdges, MilanInt *BufferSize, MilanLongInt *Buffer, @@ -207,4 +206,3 @@ void sendBundledMessages(MilanLongInt *numGhostEdges, } } } -#endif From 677e4fe6bc0e9efa8b8cef949f73304e55c66268 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 5 Jun 2024 15:13:18 +0200 Subject: [PATCH 42/51] Modify MatchBox names with D in preparation for S version --- amgprec/impl/aggregator/MatchBoxPC.h | 2 +- ...goDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp | 2 +- amgprec/impl/aggregator/processExposedVertex.cpp | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/amgprec/impl/aggregator/MatchBoxPC.h b/amgprec/impl/aggregator/MatchBoxPC.h index 4214993e..8e12c49c 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.h +++ b/amgprec/impl/aggregator/MatchBoxPC.h @@ -266,7 +266,7 @@ is disabled there is no reason to actually compile or reference them. */ MilanReal *edgeLocWeight, MilanLongInt *candidateMate); - void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, + void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(MilanLongInt NLVer, MilanLongInt *candidateMate, MilanLongInt *verLocInd, MilanLongInt *verLocPtr, diff --git a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp index c9199ea5..cc9d1d52 100644 --- a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp +++ b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp @@ -268,7 +268,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( * TODO: Test when it's actually more efficient to execute this code * in parallel. */ - PARALLEL_PROCESS_EXPOSED_VERTEX_B(NLVer, + PARALLEL_PROCESS_EXPOSED_VERTEX_BD(NLVer, candidateMate, verLocInd, verLocPtr, diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index f91109ca..d0dfe96b 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -1,5 +1,5 @@ #include "MatchBoxPC.h" -void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, +void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(MilanLongInt NLVer, MilanLongInt *candidateMate, MilanLongInt *verLocInd, MilanLongInt *verLocPtr, From 803d311d1c84fa00bc6f00bf81af169e3665c426 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Thu, 6 Jun 2024 17:12:31 +0200 Subject: [PATCH 43/51] S versions. Take out parallel in a few places --- amgprec/impl/aggregator/MatchBoxPC.cpp | 40 +- amgprec/impl/aggregator/MatchBoxPC.h | 159 ++++++ ...DomEdgesLinearSearchMesgBndlSmallMateC.cpp | 20 +- ...mEdgesLinearSearchMesgBndlSmallMateCMP.cpp | 483 ++++++++++++++++++ .../impl/aggregator/computeCandidateMate.cpp | 64 +++ .../parallelComputeCandidateMateB.cpp | 27 + .../impl/aggregator/processExposedVertex.cpp | 188 ++++++- .../aggregator/processMatchedVertices.cpp | 293 +++++++++++ .../processMatchedVerticesAndSendMessages.cpp | 295 +++++++++++ amgprec/impl/aggregator/processMessages.cpp | 320 +++++++++++- .../impl/aggregator/sendBundledMessages.cpp | 36 +- 11 files changed, 1879 insertions(+), 46 deletions(-) diff --git a/amgprec/impl/aggregator/MatchBoxPC.cpp b/amgprec/impl/aggregator/MatchBoxPC.cpp index 65a910b1..c49ce8d4 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.cpp +++ b/amgprec/impl/aggregator/MatchBoxPC.cpp @@ -68,9 +68,9 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge, #define TIME_TRACKER - #ifdef TIME_TRACKER - double tmr = MPI_Wtime(); - #endif +#ifdef TIME_TRACKER + double tmr = MPI_Wtime(); +#endif #if 1 // defined(OPENMP) @@ -93,11 +93,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 } @@ -115,13 +115,25 @@ 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 1 + // 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 8e12c49c..f1a7245b 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.h +++ b/amgprec/impl/aggregator/MatchBoxPC.h @@ -189,6 +189,7 @@ is disabled there is no reason to actually compile or reference them. */ MilanLongInt adj2, MilanLongInt *verLocInd, MilanReal *edgeLocWeight); + void queuesTransfer(vector &U, vector &privateU, @@ -417,6 +418,153 @@ is disabled there is no reason to actually compile or reference them. */ 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, @@ -428,6 +576,17 @@ is disabled there is no reason to actually compile or reference them. */ 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( 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("< 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 " < &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 +} diff --git a/amgprec/impl/aggregator/processMatchedVertices.cpp b/amgprec/impl/aggregator/processMatchedVertices.cpp index 62db3efc..2b2160e9 100644 --- a/amgprec/impl/aggregator/processMatchedVertices.cpp +++ b/amgprec/impl/aggregator/processMatchedVertices.cpp @@ -289,3 +289,296 @@ void processMatchedVerticesD( #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 09ed7ab4..40d333a7 100644 --- a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp +++ b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp @@ -292,3 +292,298 @@ void processMatchedVerticesAndSendMessagesD( 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, + 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 = 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); + + // 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"<= 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; + 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 = 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; diff --git a/amgprec/impl/aggregator/sendBundledMessages.cpp b/amgprec/impl/aggregator/sendBundledMessages.cpp index 54736f7a..debabf7e 100644 --- a/amgprec/impl/aggregator/sendBundledMessages.cpp +++ b/amgprec/impl/aggregator/sendBundledMessages.cpp @@ -1,23 +1,23 @@ #include "MatchBoxPC.h" 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; From 818ead5878c2c0070ceeaa68dbd9db6a132eef1d Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 11 Jun 2024 09:52:11 +0200 Subject: [PATCH 44/51] Try changes for matching --- amgprec/amg_s_matchboxp_mod.f90 | 2 -- amgprec/impl/aggregator/processMatchedVertices.cpp | 2 +- .../impl/aggregator/processMatchedVerticesAndSendMessages.cpp | 4 ++-- amgprec/impl/level/amg_d_base_onelev_memory_use.f90 | 3 +-- 4 files changed, 4 insertions(+), 7 deletions(-) diff --git a/amgprec/amg_s_matchboxp_mod.f90 b/amgprec/amg_s_matchboxp_mod.f90 index a7f41c24..04194836 100644 --- a/amgprec/amg_s_matchboxp_mod.f90 +++ b/amgprec/amg_s_matchboxp_mod.f90 @@ -272,9 +272,7 @@ contains write(0,*) 'Impossible: mate(k) > nc' cycle else - if (ilaggr(k) == ilaggr_neginit) then - wk = w(k) widx = w(idx) wmax = max(abs(wk),abs(widx)) diff --git a/amgprec/impl/aggregator/processMatchedVertices.cpp b/amgprec/impl/aggregator/processMatchedVertices.cpp index 2b2160e9..531c9d32 100644 --- a/amgprec/impl/aggregator/processMatchedVertices.cpp +++ b/amgprec/impl/aggregator/processMatchedVertices.cpp @@ -338,7 +338,7 @@ void processMatchedVerticesS( #ifdef COUNT_LOCAL_VERTEX MilanLongInt localVertices = 0; #endif - //#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \ +#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) \ diff --git a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp index 40d333a7..1631348d 100644 --- a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp +++ b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp @@ -26,7 +26,7 @@ void processMatchedVerticesAndSendMessagesD( vector &QLocalVtx, vector &QGhostVtx, vector &QMsgType, - vector &QOwner, + vector &QOwner, vector &privateQLocalVtx, vector &privateQGhostVtx, vector &privateQMsgType, @@ -345,7 +345,7 @@ void processMatchedVerticesAndSendMessagesS( #ifdef COUNT_LOCAL_VERTEX MilanLongInt localVertices = 0; #endif - //#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \ +#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) \ diff --git a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 index 25534fd0..da56851c 100644 --- a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 @@ -98,8 +98,7 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi prefix_ = "" end if - write(iout_,*) trim(prefix_) - + if (me == 0) write(iout_,*) trim(prefix_) if (global_) then allocate(sz(6)) From 3ff1ad9372eb0dd0fb4d0a733a226d471ca2749c Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 11 Jun 2024 09:54:55 +0200 Subject: [PATCH 45/51] Fix noise in %memory_use() --- amgprec/impl/level/amg_c_base_onelev_memory_use.f90 | 3 +-- amgprec/impl/level/amg_d_base_onelev_memory_use.f90 | 3 +-- amgprec/impl/level/amg_s_base_onelev_memory_use.f90 | 3 +-- amgprec/impl/level/amg_z_base_onelev_memory_use.f90 | 3 +-- 4 files changed, 4 insertions(+), 8 deletions(-) diff --git a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 index 4b58000d..71719304 100644 --- a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 @@ -98,8 +98,7 @@ subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi prefix_ = "" end if - write(iout_,*) trim(prefix_) - + if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) if (global_) then allocate(sz(6)) diff --git a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 index 25534fd0..3edc5999 100644 --- a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 @@ -98,8 +98,7 @@ subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi prefix_ = "" end if - write(iout_,*) trim(prefix_) - + if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) if (global_) then allocate(sz(6)) diff --git a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 index 9709ba3e..8cc5a4fa 100644 --- a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 @@ -98,8 +98,7 @@ subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi prefix_ = "" end if - write(iout_,*) trim(prefix_) - + if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) if (global_) then allocate(sz(6)) diff --git a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 index 0e12a6bc..6682ff2d 100644 --- a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 @@ -98,8 +98,7 @@ subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefi prefix_ = "" end if - write(iout_,*) trim(prefix_) - + if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) if (global_) then allocate(sz(6)) From 96a700cb9dd77fe35a9d1790b67e0c858c784784 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 3 Jul 2024 10:58:00 +0200 Subject: [PATCH 46/51] Workaround for save_smoothers bug with gcc-13.3.0 --- ...rarchy_bld.f90 => amg_c_hierarchy_bld.F90} | 67 ++++++++++++++++++- ...rarchy_bld.f90 => amg_d_hierarchy_bld.F90} | 67 ++++++++++++++++++- ...rarchy_bld.f90 => amg_s_hierarchy_bld.F90} | 67 ++++++++++++++++++- ...rarchy_bld.f90 => amg_z_hierarchy_bld.F90} | 67 ++++++++++++++++++- 4 files changed, 264 insertions(+), 4 deletions(-) rename amgprec/impl/{amg_c_hierarchy_bld.f90 => amg_c_hierarchy_bld.F90} (90%) rename amgprec/impl/{amg_d_hierarchy_bld.f90 => amg_d_hierarchy_bld.F90} (90%) rename amgprec/impl/{amg_s_hierarchy_bld.f90 => amg_s_hierarchy_bld.F90} (90%) rename amgprec/impl/{amg_z_hierarchy_bld.f90 => amg_z_hierarchy_bld.F90} (90%) 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_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_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_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 From 6362db0cc5ac59680046b5e2100c45712d84afec Mon Sep 17 00:00:00 2001 From: sfilippone Date: Wed, 3 Jul 2024 11:00:13 +0200 Subject: [PATCH 47/51] Try improve OpenMP version of matchbox --- amgprec/amg_d_matchboxp_mod.f90 | 1 + ...mEdgesLinearSearchMesgBndlSmallMateCMP.cpp | 2 +- .../impl/aggregator/processExposedVertex.cpp | 22 ++++++++++--------- .../processMatchedVerticesAndSendMessages.cpp | 19 ++++++++-------- 4 files changed, 24 insertions(+), 20 deletions(-) diff --git a/amgprec/amg_d_matchboxp_mod.f90 b/amgprec/amg_d_matchboxp_mod.f90 index e19ce617..5e0151ec 100644 --- a/amgprec/amg_d_matchboxp_mod.f90 +++ b/amgprec/amg_d_matchboxp_mod.f90 @@ -724,6 +724,7 @@ contains & vnl, mate, iam, np,ictxt,& & msgis,msgas,msgprc,ph0t,ph1t,ph2t,ph1crd,ph2crd,info,display_inp) if (do_timings) call psb_toc(idx_cmboxp) + if (iam==0) write(0,*) iam,' buildmatching from PMatchBox:', info,ph0t,ph1t,ph2t if (debug) write(0,*) iam,' buildmatching from PMatchBox:', info if (debug_sync) then call psb_max(ictxt,info) diff --git a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp index 742f2b85..3b478cd7 100644 --- a/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp +++ b/amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp @@ -489,7 +489,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP( /////////////////////////////////////////////////////////////////////////////////// /////////////////////////// PROCESS MESSAGES ////////////////////////////////////// /////////////////////////////////////////////////////////////////////////////////// - + //startTime = MPI_Wtime(); processMessagesD(NLVer, Mate, candidateMate, diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index cf0fb826..cb3cea65 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -30,15 +30,16 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(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 \ @@ -216,17 +217,18 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_BS(MilanLongInt NLVer, 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) \ +#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 \ - [:1]) \ - schedule(static) + [:1]) \ + schedule(static) for (v = 0; v < NLVer; v++) { option = -1; // Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v) diff --git a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp index 1631348d..d094afaa 100644 --- a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp +++ b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp @@ -51,15 +51,16 @@ void processMatchedVerticesAndSendMessagesD( 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]) + 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()) { From e88d176fedc513a30d6e11beb3da86f7ada7a829 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 5 Jul 2024 12:10:26 +0200 Subject: [PATCH 48/51] Switch off OpenMP in processExposedVertex --- amgprec/impl/aggregator/processExposedVertex.cpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index c53af9bb..ecc5cf41 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -34,12 +34,12 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer, 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) \ + //#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 \ From 89e2d53e8b269bfc5e7c2d652461970ad70d98fd Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 5 Jul 2024 13:56:38 +0200 Subject: [PATCH 49/51] Silence debug print. --- amgprec/amg_d_matchboxp_mod.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/amgprec/amg_d_matchboxp_mod.f90 b/amgprec/amg_d_matchboxp_mod.f90 index 5e0151ec..e19ce617 100644 --- a/amgprec/amg_d_matchboxp_mod.f90 +++ b/amgprec/amg_d_matchboxp_mod.f90 @@ -724,7 +724,6 @@ contains & vnl, mate, iam, np,ictxt,& & msgis,msgas,msgprc,ph0t,ph1t,ph2t,ph1crd,ph2crd,info,display_inp) if (do_timings) call psb_toc(idx_cmboxp) - if (iam==0) write(0,*) iam,' buildmatching from PMatchBox:', info,ph0t,ph1t,ph2t if (debug) write(0,*) iam,' buildmatching from PMatchBox:', info if (debug_sync) then call psb_max(ictxt,info) From 2f5072166d845f2ea361044a99afb5252c8203e2 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 5 Jul 2024 13:56:52 +0200 Subject: [PATCH 50/51] Switch off OpenMP in certain sections of MatchBOXP --- amgprec/impl/aggregator/MatchBoxPC.cpp | 2 +- amgprec/impl/aggregator/processExposedVertex.cpp | 8 ++++---- amgprec/impl/aggregator/processMatchedVertices.cpp | 2 +- .../aggregator/processMatchedVerticesAndSendMessages.cpp | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/amgprec/impl/aggregator/MatchBoxPC.cpp b/amgprec/impl/aggregator/MatchBoxPC.cpp index c49ce8d4..ef0cb3ef 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.cpp +++ b/amgprec/impl/aggregator/MatchBoxPC.cpp @@ -67,7 +67,7 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge, #endif -#define TIME_TRACKER +#undef TIME_TRACKER #ifdef TIME_TRACKER double tmr = MPI_Wtime(); #endif diff --git a/amgprec/impl/aggregator/processExposedVertex.cpp b/amgprec/impl/aggregator/processExposedVertex.cpp index cb3cea65..7dfab012 100644 --- a/amgprec/impl/aggregator/processExposedVertex.cpp +++ b/amgprec/impl/aggregator/processExposedVertex.cpp @@ -33,13 +33,13 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(MilanLongInt NLVer, 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) \ + //#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 \ @@ -217,13 +217,13 @@ void PARALLEL_PROCESS_EXPOSED_VERTEX_BS(MilanLongInt NLVer, 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) \ + //#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 \ diff --git a/amgprec/impl/aggregator/processMatchedVertices.cpp b/amgprec/impl/aggregator/processMatchedVertices.cpp index 531c9d32..2b2160e9 100644 --- a/amgprec/impl/aggregator/processMatchedVertices.cpp +++ b/amgprec/impl/aggregator/processMatchedVertices.cpp @@ -338,7 +338,7 @@ void processMatchedVerticesS( #ifdef COUNT_LOCAL_VERTEX MilanLongInt localVertices = 0; #endif -#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \ + //#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) \ diff --git a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp index d094afaa..1e1ba4b7 100644 --- a/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp +++ b/amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp @@ -346,7 +346,7 @@ void processMatchedVerticesAndSendMessagesS( #ifdef COUNT_LOCAL_VERTEX MilanLongInt localVertices = 0; #endif -#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \ + //#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) \ From c1e8bc0c571925c4b3a5007b0172920cbec4e12f Mon Sep 17 00:00:00 2001 From: sfilippone Date: Fri, 5 Jul 2024 14:23:44 +0200 Subject: [PATCH 51/51] Do not use OpenMP code for serial version --- amgprec/impl/aggregator/MatchBoxPC.cpp | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/amgprec/impl/aggregator/MatchBoxPC.cpp b/amgprec/impl/aggregator/MatchBoxPC.cpp index ef0cb3ef..8295c0af 100644 --- a/amgprec/impl/aggregator/MatchBoxPC.cpp +++ b/amgprec/impl/aggregator/MatchBoxPC.cpp @@ -72,8 +72,7 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge, double tmr = MPI_Wtime(); #endif -#if 1 - // defined(OPENMP) +#if defined(OPENMP) //fprintf(stderr,"Warning: using buggy OpenMP matching!\n"); dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge, verLocPtr, verLocInd, edgeLocWeight, @@ -115,8 +114,7 @@ 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 1 - // defined(OPENMP) +#if defined(OPENMP) //fprintf(stderr,"Warning: using buggy OpenMP matching!\n"); salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge, verLocPtr, verLocInd, edgeLocWeight,