Defined Jacobi and L1-JACOBI solvers.

(Might have solved stucked runs)

README.md

@@ -1,4 +1,3 @@
-
                          AMG4PSBLAS  
  Algebraic Multigrid Package  based on PSBLAS (Parallel Sparse BLAS version 3.8)
     

amgprec/Makefile

@@ -11,7 +11,7 @@ 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_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_gs_solver.o amg_d_mumps_solver.o amg_d_jac_solver.o \
 	amg_d_base_aggregator_mod.o \
 	amg_d_dec_aggregator_mod.o amg_d_symdec_aggregator_mod.o \
 	amg_d_ainv_solver.o amg_d_base_ainv_mod.o \
@@ -22,7 +22,7 @@ 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_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_gs_solver.o amg_s_mumps_solver.o  amg_s_jac_solver.o \
 	amg_s_base_aggregator_mod.o  \
 	amg_s_dec_aggregator_mod.o amg_s_symdec_aggregator_mod.o \
 	amg_s_ainv_solver.o amg_s_base_ainv_mod.o \
@@ -33,7 +33,7 @@ ZMODOBJS=amg_z_prec_type.o amg_z_ilu_fact_mod.o \
 	amg_z_inner_mod.o amg_z_ilu_solver.o amg_z_diag_solver.o amg_z_jac_smoother.o amg_z_as_smoother.o \
 	amg_z_umf_solver.o amg_z_slu_solver.o amg_z_sludist_solver.o amg_z_id_solver.o\
 	amg_z_base_solver_mod.o amg_z_base_smoother_mod.o amg_z_onelev_mod.o \
-	amg_z_gs_solver.o amg_z_mumps_solver.o \
+	amg_z_gs_solver.o amg_z_mumps_solver.o  amg_z_jac_solver.o \
 	amg_z_base_aggregator_mod.o  \
 	amg_z_dec_aggregator_mod.o amg_z_symdec_aggregator_mod.o \
 	amg_z_ainv_solver.o amg_z_base_ainv_mod.o \
@@ -43,7 +43,7 @@ CMODOBJS=amg_c_prec_type.o amg_c_ilu_fact_mod.o \
 	amg_c_inner_mod.o amg_c_ilu_solver.o amg_c_diag_solver.o amg_c_jac_smoother.o amg_c_as_smoother.o \
 	amg_c_slu_solver.o amg_c_id_solver.o\
 	amg_c_base_solver_mod.o amg_c_base_smoother_mod.o amg_c_onelev_mod.o  \
-	amg_c_gs_solver.o amg_c_mumps_solver.o \
+	amg_c_gs_solver.o amg_c_mumps_solver.o  amg_c_jac_solver.o \
 	amg_c_base_aggregator_mod.o  \
 	amg_c_dec_aggregator_mod.o amg_c_symdec_aggregator_mod.o \
 	amg_c_ainv_solver.o amg_c_base_ainv_mod.o \
@@ -155,7 +155,7 @@ amg_z_base_ainv_mod.o: amg_z_base_solver_mod.o amg_base_ainv_mod.o
 amg_s_base_solver_mod.o amg_d_base_solver_mod.o amg_c_base_solver_mod.o amg_z_base_solver_mod.o: amg_base_prec_type.o
 
 amg_d_mumps_solver.o amg_d_gs_solver.o amg_d_id_solver.o amg_d_sludist_solver.o amg_d_slu_solver.o \
-amg_d_umf_solver.o amg_d_diag_solver.o amg_d_ilu_solver.o: amg_d_base_solver_mod.o  amg_d_prec_type.o
+amg_d_umf_solver.o amg_d_diag_solver.o amg_d_ilu_solver.o amg_d_jac_solver.o: amg_d_base_solver_mod.o  amg_d_prec_type.o
 
 #amg_d_ilu_fact_mod.o: amg_base_prec_type.o  amg_d_base_solver_mod.o
 #amg_d_ilu_solver.o amg_d_iluk_fact.o: amg_d_ilu_fact_mod.o
@@ -166,7 +166,7 @@ amg_dprecinit.o amg_dprecset.o: amg_d_diag_solver.o amg_d_ilu_solver.o \
 	        amg_d_id_solver.o amg_d_slu_solver.o amg_d_sludist_solver.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_base_solver_mod.o  amg_s_prec_type.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
 amg_s_ilu_fact_mod.o: amg_base_prec_type.o  amg_s_base_solver_mod.o
 amg_s_ilu_solver.o amg_s_iluk_fact.o: amg_s_ilu_fact_mod.o
 amg_s_as_smoother.o amg_s_jac_smoother.o: amg_s_base_smoother_mod.o
@@ -176,7 +176,7 @@ amg_sprecinit.o amg_sprecset.o: amg_s_diag_solver.o amg_s_ilu_solver.o \
 	        amg_s_id_solver.o amg_s_slu_solver.o
 
 amg_z_mumps_solver.o amg_z_gs_solver.o amg_z_id_solver.o amg_z_sludist_solver.o amg_z_slu_solver.o \
-amg_z_umf_solver.o amg_z_diag_solver.o amg_z_ilu_solver.o: amg_z_base_solver_mod.o  amg_z_prec_type.o
+amg_z_umf_solver.o amg_z_diag_solver.o amg_z_ilu_solver.o amg_z_jac_solver.o: amg_z_base_solver_mod.o  amg_z_prec_type.o
 amg_z_ilu_fact_mod.o: amg_base_prec_type.o  amg_z_base_solver_mod.o
 amg_z_ilu_solver.o amg_z_iluk_fact.o: amg_z_ilu_fact_mod.o
 amg_z_as_smoother.o amg_z_jac_smoother.o: amg_z_base_smoother_mod.o
@@ -186,7 +186,7 @@ amg_zprecinit.o amg_zprecset.o: amg_z_diag_solver.o amg_z_ilu_solver.o \
 	        amg_z_id_solver.o amg_z_slu_solver.o amg_z_sludist_solver.o
 
 amg_c_mumps_solver.o amg_c_gs_solver.o amg_c_id_solver.o amg_c_sludist_solver.o amg_c_slu_solver.o \
-amg_c_diag_solver.o amg_c_ilu_solver.o: amg_c_base_solver_mod.o  amg_c_prec_type.o
+amg_c_diag_solver.o amg_c_ilu_solver.o amg_c_jac_solver.o: amg_c_base_solver_mod.o  amg_c_prec_type.o
 amg_c_ilu_fact_mod.o: amg_base_prec_type.o  amg_c_base_solver_mod.o
 amg_c_ilu_solver.o amg_c_iluk_fact.o: amg_c_ilu_fact_mod.o
 amg_c_as_smoother.o amg_c_jac_smoother.o: amg_c_base_smoother_mod.o

amgprec/amg_c_ainv_solver.F90

@@ -58,6 +58,7 @@ module amg_c_ainv_solver
     procedure, pass(sv) :: check   => amg_c_ainv_solver_check
     procedure, pass(sv) :: build   => amg_c_ainv_solver_bld
     procedure, pass(sv) :: clone   => amg_c_ainv_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_c_ainv_solver_clone_settings
     procedure, pass(sv) :: cseti   => amg_c_ainv_solver_cseti
     procedure, pass(sv) :: csetc   => amg_c_ainv_solver_csetc
     procedure, pass(sv) :: csetr   => amg_c_ainv_solver_csetr
@@ -85,6 +86,16 @@ module amg_c_ainv_solver
     end subroutine amg_c_ainv_solver_clone
   end interface
 
+  interface
+    subroutine amg_c_ainv_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+       & amg_c_base_solver_type, psb_dpk_, amg_c_ainv_solver_type, psb_ipk_
+      Implicit None
+      class(amg_c_ainv_solver_type), intent(inout)              :: sv
+      class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_c_ainv_solver_clone_settings
+  end interface
 
   interface
     subroutine amg_c_ainv_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)

amgprec/amg_c_invk_solver.f90

@@ -52,6 +52,7 @@ module amg_c_invk_solver
   contains
     procedure, pass(sv) :: check   => amg_c_invk_solver_check
     procedure, pass(sv) :: clone   => amg_c_invk_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_c_invk_solver_clone_settings
     procedure, pass(sv) :: build   => amg_c_invk_solver_bld
     procedure, pass(sv) :: cseti   => amg_c_invk_solver_cseti
     procedure, pass(sv) :: descr   => amg_c_invk_solver_descr
@@ -73,6 +74,17 @@ module amg_c_invk_solver
     end subroutine amg_c_invk_solver_clone
   end interface
 
+  interface
+    subroutine amg_c_invk_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+       & amg_c_base_solver_type, psb_spk_, amg_c_invk_solver_type, psb_ipk_
+      Implicit None
+      class(amg_c_invk_solver_type), intent(inout)              :: sv
+      class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_c_invk_solver_clone_settings
+  end interface
+
   interface
     subroutine amg_c_invk_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &

amgprec/amg_c_invt_solver.f90

@@ -52,6 +52,7 @@ module amg_c_invt_solver
   contains
     procedure, pass(sv) :: check   => amg_c_invt_solver_check
     procedure, pass(sv) :: clone   => amg_c_invt_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_c_invt_solver_clone_settings
     procedure, pass(sv) :: build   => amg_c_invt_solver_bld
     procedure, pass(sv) :: cseti   => amg_c_invt_solver_cseti
     procedure, pass(sv) :: csetr   => amg_c_invt_solver_csetr
@@ -73,6 +74,17 @@ module amg_c_invt_solver
     end subroutine amg_c_invt_solver_clone
   end interface
 
+  interface
+    subroutine amg_c_invt_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+       & amg_c_base_solver_type, psb_spk_, amg_c_invt_solver_type, psb_ipk_
+      Implicit None
+      class(amg_c_invt_solver_type), intent(inout)              :: sv
+      class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_c_invt_solver_clone_settings
+  end interface
+
   interface
     subroutine amg_c_invt_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &

amgprec/amg_c_jac_solver.f90

@@ -0,0 +1,582 @@
+!  
+!   
+!                             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_c_jac_solver_mod.f90
+!
+! Module: amg_c_jac_solver_mod
+!
+!  This module defines: 
+!  - the amg_c_jac_solver_type data structure containing the ingredients
+!    for a local Jacobi  iteration. The iterations are local to a process
+!    (they operate on the block diagonal).
+!    
+!
+module amg_c_jac_solver
+
+  use amg_c_base_solver_mod
+
+  type, extends(amg_c_base_solver_type) :: amg_c_jac_solver_type
+    type(psb_cspmat_type)      :: a
+    type(psb_c_vect_type), allocatable :: dv
+    complex(psb_spk_), allocatable        :: d(:)
+    integer(psb_ipk_)          :: sweeps
+    real(psb_spk_)             :: eps
+  contains
+    procedure, pass(sv) :: dump    => amg_c_jac_solver_dmp
+    procedure, pass(sv) :: check   => c_jac_solver_check
+    procedure, pass(sv) :: clone   => amg_c_jac_solver_clone
+    procedure, pass(sv) :: clone_settings => amg_c_jac_solver_clone_settings
+    procedure, pass(sv) :: clear_data     => amg_c_jac_solver_clear_data
+    procedure, pass(sv) :: build   => amg_c_jac_solver_bld
+    procedure, pass(sv) :: cnv     => amg_c_jac_solver_cnv
+    procedure, pass(sv) :: apply_v => amg_c_jac_solver_apply_vect
+    procedure, pass(sv) :: apply_a => amg_c_jac_solver_apply
+    procedure, pass(sv) :: free    => c_jac_solver_free
+    procedure, pass(sv) :: cseti   => c_jac_solver_cseti
+    procedure, pass(sv) :: csetc   => c_jac_solver_csetc
+    procedure, pass(sv) :: csetr   => c_jac_solver_csetr
+    procedure, pass(sv) :: descr   => c_jac_solver_descr
+    procedure, pass(sv) :: default => c_jac_solver_default
+    procedure, pass(sv) :: sizeof  => c_jac_solver_sizeof
+    procedure, pass(sv) :: get_nzeros => c_jac_solver_get_nzeros
+    procedure, nopass   :: get_wrksz  => c_jac_solver_get_wrksize
+    procedure, nopass   :: get_fmt    => c_jac_solver_get_fmt
+    procedure, nopass   :: get_id     => c_jac_solver_get_id
+    procedure, nopass   :: is_iterative => c_jac_solver_is_iterative
+  end type amg_c_jac_solver_type
+
+  type, extends(amg_c_jac_solver_type) :: amg_c_l1_jac_solver_type
+  contains
+    procedure, pass(sv) :: build   => amg_c_l1_jac_solver_bld
+    procedure, pass(sv) :: descr   => c_l1_jac_solver_descr
+    procedure, nopass   :: get_fmt    => c_l1_jac_solver_get_fmt
+    procedure, nopass   :: get_id     => c_l1_jac_solver_get_id
+  end type amg_c_l1_jac_solver_type
+
+
+  private :: c_jac_solver_bld, c_jac_solver_apply, &
+       &  c_jac_solver_free,   &
+       &  c_jac_solver_descr,  c_jac_solver_sizeof, &
+       &  c_jac_solver_default, c_jac_solver_dmp, &
+       &  c_jac_solver_apply_vect, c_jac_solver_get_nzeros, &
+       &  c_jac_solver_get_fmt, c_jac_solver_check,&
+       &  c_jac_solver_is_iterative, &
+       &  c_jac_solver_get_id, c_jac_solver_get_wrksize
+
+  interface 
+    subroutine amg_c_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
+         & trans,work,wv,info,init,initu)
+      import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
+           & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
+      implicit none 
+      type(psb_desc_type), intent(in)             :: desc_data
+      class(amg_c_jac_solver_type), intent(inout) :: sv
+      type(psb_c_vect_type),intent(inout)         :: x
+      type(psb_c_vect_type),intent(inout)         :: y
+      complex(psb_spk_),intent(in)                    :: alpha,beta
+      character(len=1),intent(in)                   :: trans
+      complex(psb_spk_),target, intent(inout)         :: work(:)
+      type(psb_c_vect_type),intent(inout)         :: wv(:)
+      integer(psb_ipk_), intent(out)                :: info
+      character, intent(in), optional                :: init
+      type(psb_c_vect_type),intent(inout), optional   :: initu
+    end subroutine amg_c_jac_solver_apply_vect
+  end interface
+
+  interface 
+    subroutine amg_c_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
+      import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
+           & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
+      implicit none 
+      type(psb_desc_type), intent(in)      :: desc_data
+      class(amg_c_jac_solver_type), intent(inout) :: sv
+      complex(psb_spk_),intent(inout)         :: x(:)
+      complex(psb_spk_),intent(inout)         :: y(:)
+      complex(psb_spk_),intent(in)            :: alpha,beta
+      character(len=1),intent(in)           :: trans
+      complex(psb_spk_),target, intent(inout) :: work(:)
+      integer(psb_ipk_), intent(out)        :: info
+      character, intent(in), optional       :: init
+      complex(psb_spk_),intent(inout), optional :: initu(:)
+    end subroutine amg_c_jac_solver_apply
+  end interface
+
+  interface 
+    subroutine amg_c_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+      import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
+           & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      implicit none 
+      type(psb_cspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a 
+      class(amg_c_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      type(psb_cspmat_type), intent(in), target, optional :: b
+      class(psb_c_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_c_base_vect_type), intent(in), optional   :: vmold
+      class(psb_i_base_vect_type), intent(in), optional   :: imold
+    end subroutine amg_c_jac_solver_bld
+  end interface
+
+  interface 
+    subroutine amg_c_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+      import :: psb_desc_type, amg_c_l1_jac_solver_type, psb_c_vect_type, psb_spk_, &
+           & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      implicit none 
+      type(psb_cspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a 
+      class(amg_c_l1_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      type(psb_cspmat_type), intent(in), target, optional :: b
+      class(psb_c_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_c_base_vect_type), intent(in), optional   :: vmold
+      class(psb_i_base_vect_type), intent(in), optional   :: imold
+    end subroutine amg_c_l1_jac_solver_bld
+  end interface
+
+  interface 
+    subroutine amg_c_jac_solver_cnv(sv,info,amold,vmold,imold)
+      import :: amg_c_jac_solver_type, psb_spk_, &
+           & psb_c_base_sparse_mat, psb_c_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      implicit none 
+      class(amg_c_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      class(psb_c_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_c_base_vect_type), intent(in), optional   :: vmold
+      class(psb_i_base_vect_type), intent(in), optional   :: imold
+    end subroutine amg_c_jac_solver_cnv
+  end interface
+  
+  interface 
+    subroutine amg_c_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
+      import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
+           & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, &
+           & psb_ipk_
+      implicit none 
+      class(amg_c_jac_solver_type), intent(in) :: sv
+      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)              :: solver, global_num
+    end subroutine amg_c_jac_solver_dmp
+  end interface
+  
+  interface
+    subroutine amg_c_jac_solver_clone(sv,svout,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
+           & amg_c_base_solver_type, amg_c_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_c_jac_solver_type), intent(inout)               :: sv
+      class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)              :: info
+    end subroutine amg_c_jac_solver_clone
+  end interface
+  
+!!$  interface
+!!$    subroutine amg_c_l1_jac_solver_clone(sv,svout,info)
+!!$      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+!!$           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
+!!$           & amg_c_base_solver_type, amg_c_l1_jac_solver_type, psb_ipk_
+!!$      Implicit None
+!!$      
+!!$      ! Arguments
+!!$      class(amg_c_l1_jac_solver_type), intent(inout)               :: sv
+!!$      class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
+!!$      integer(psb_ipk_), intent(out)              :: info
+!!$    end subroutine amg_c_l1_jac_solver_clone
+!!$  end interface
+
+  interface
+    subroutine amg_c_jac_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
+           & amg_c_base_solver_type, amg_c_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_c_jac_solver_type), intent(inout) :: sv
+      class(amg_c_base_solver_type), intent(inout) :: svout
+      integer(psb_ipk_), intent(out)               :: info
+    end subroutine amg_c_jac_solver_clone_settings
+  end interface
+
+  interface
+    subroutine amg_c_jac_solver_clear_data(sv,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
+           & amg_c_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_c_jac_solver_type), intent(inout) :: sv
+      integer(psb_ipk_), intent(out)                 :: info
+    end subroutine amg_c_jac_solver_clear_data
+  end interface
+
+contains
+
+  subroutine c_jac_solver_default(sv)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_c_jac_solver_type), intent(inout) :: sv
+
+    sv%sweeps = ione
+    sv%eps    = dzero
+    
+    return
+  end subroutine c_jac_solver_default
+
+  subroutine c_jac_solver_check(sv,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_c_jac_solver_type), intent(inout) :: sv
+    integer(psb_ipk_), intent(out)                :: info
+    integer(psb_ipk_) :: err_act
+    character(len=20) :: name='c_jac_solver_check'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call amg_check_def(sv%sweeps,&
+         & 'Jacobi sweeps',ione,is_int_positive)
+
+    if (info /= psb_success_) goto 9999
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine c_jac_solver_check
+
+  subroutine c_jac_solver_cseti(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_c_jac_solver_type), intent(inout) :: sv 
+    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='c_jac_solver_cseti'
+
+    info = psb_success_
+    call psb_erractionsave(err_act)
+
+    select case(psb_toupper(what))
+    case('SOLVER_SWEEPS')
+      sv%sweeps = val      
+    case default
+      call sv%amg_c_base_solver_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 c_jac_solver_cseti
+
+  subroutine c_jac_solver_csetc(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_c_jac_solver_type), intent(inout) :: sv
+    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='c_jac_solver_csetc'
+
+    info = psb_success_
+    call psb_erractionsave(err_act)
+
+
+    call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
+  
+    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 c_jac_solver_csetc
+  
+  subroutine c_jac_solver_csetr(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_c_jac_solver_type), intent(inout) :: sv 
+    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='c_jac_solver_csetr'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    select case(psb_toupper(what))
+    case('SOLVER_EPS') 
+      sv%eps = val
+    case default
+      call sv%amg_c_base_solver_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 c_jac_solver_csetr
+
+  subroutine c_jac_solver_free(sv,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_c_jac_solver_type), intent(inout) :: sv
+    integer(psb_ipk_), intent(out)                :: info
+    integer(psb_ipk_)  :: err_act
+    character(len=20)  :: name='c_jac_solver_free'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call sv%a%free()
+    call sv%dv%free(info)
+    if (allocated(sv%d)) deallocate(sv%d)
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine c_jac_solver_free
+
+  subroutine c_jac_solver_descr(sv,info,iout,coarse,prefix)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_c_jac_solver_type), intent(in) :: sv
+    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_c_jac_solver_descr'
+    integer(psb_ipk_) :: iout_
+    character(1024)    :: prefix_
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+    if (present(iout)) then 
+      iout_ = iout 
+    else
+      iout_ = psb_out_unit
+    endif
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if (sv%eps<=dzero) then 
+      write(iout_,*) trim(prefix_), '  Jacobi iterative solver with  ',&
+           &  sv%sweeps,' sweeps'
+    else
+      write(iout_,*) trim(prefix_), '  Jacobi iterative solver with  tolerance',&
+           &  sv%eps,' and maxit', sv%sweeps
+    end if
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine c_jac_solver_descr
+
+  function c_jac_solver_get_nzeros(sv) result(val)
+
+    implicit none 
+    ! Arguments
+    class(amg_c_jac_solver_type), intent(in) :: sv
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+    
+    val = 0 
+    val = val + sv%a%get_nzeros()
+    val = val + sv%dv%get_nrows()
+
+    return
+  end function c_jac_solver_get_nzeros
+
+  function c_jac_solver_sizeof(sv) result(val)
+
+    implicit none 
+    ! Arguments
+    class(amg_c_jac_solver_type), intent(in) :: sv
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+
+    val = psb_sizeof_ip 
+    val = val + sv%a%sizeof()
+    val = val + sv%dv%sizeof()
+
+    return
+  end function c_jac_solver_sizeof
+
+  function c_jac_solver_get_fmt() result(val)
+    implicit none 
+    character(len=32)  :: val
+
+    val = "Jacobi solver"
+  end function c_jac_solver_get_fmt
+
+  function c_jac_solver_get_id() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = amg_jac_
+  end function c_jac_solver_get_id
+
+  !
+  ! If this is true, then the solver needs a starting
+  ! guess. Currently only handled in JAC smoother. 
+  ! 
+  function c_jac_solver_is_iterative() result(val)
+    implicit none 
+    logical  :: val
+
+    val = .true.
+  end function c_jac_solver_is_iterative
+    
+  function c_jac_solver_get_wrksize() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = 2
+  end function c_jac_solver_get_wrksize
+
+  subroutine c_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_c_l1_jac_solver_type), intent(in) :: sv
+    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_c_l1_jac_solver_descr'
+    integer(psb_ipk_) :: iout_
+    character(1024)    :: prefix_
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+    if (present(iout)) then 
+      iout_ = iout 
+    else
+      iout_ = psb_out_unit
+    endif
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if (sv%eps<=dzero) then 
+      write(iout_,*) trim(prefix_), '  L1-Jacobi iterative solver with  ',&
+           &  sv%sweeps,' sweeps'
+    else
+      write(iout_,*) trim(prefix_), '  L1-Jacobi iterative solver with  tolerance',&
+           &  sv%eps,' and maxit', sv%sweeps
+    end if
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine c_l1_jac_solver_descr
+
+  function c_l1_jac_solver_get_fmt() result(val)
+    implicit none 
+    character(len=32)  :: val
+
+    val = "L1-Jacobi solver"
+  end function c_l1_jac_solver_get_fmt
+
+  function c_l1_jac_solver_get_id() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = amg_l1_jac_
+  end function c_l1_jac_solver_get_id
+  
+end module amg_c_jac_solver

amgprec/amg_c_mumps_solver.F90

@@ -78,7 +78,8 @@ module amg_c_mumps_solver
     !
     ! Controls to be set before MUMPS instantiation:
     !
-    ! IPAR(1) : MUMPS_LOC_GLOB   0==amg_local_solver_: LOCAL   1==amg_global_solver_: GLOBAL
+    ! IPAR(1) : MUMPS_LOC_GLOB   0==amg_local_solver_: 'LOCAL_SOLVER
+    !                            1==amg_global_solver_: 'GLOBAL_SOLVER'
     ! IPAR(2) : MUMPS_PRINT_ERR  print verbosity (see MUMPS)
     ! IPAR(3) : MUMPS_SYM        0: non-symmetric   2: symmetric
     integer(psb_ipk_), dimension(3) :: ipar

amgprec/amg_d_ainv_solver.F90

@@ -58,6 +58,7 @@ module amg_d_ainv_solver
     procedure, pass(sv) :: check   => amg_d_ainv_solver_check
     procedure, pass(sv) :: build   => amg_d_ainv_solver_bld
     procedure, pass(sv) :: clone   => amg_d_ainv_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_d_ainv_solver_clone_settings
     procedure, pass(sv) :: cseti   => amg_d_ainv_solver_cseti
     procedure, pass(sv) :: csetc   => amg_d_ainv_solver_csetc
     procedure, pass(sv) :: csetr   => amg_d_ainv_solver_csetr
@@ -85,6 +86,16 @@ module amg_d_ainv_solver
     end subroutine amg_d_ainv_solver_clone
   end interface
 
+  interface
+    subroutine amg_d_ainv_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+       & amg_d_base_solver_type, psb_dpk_, amg_d_ainv_solver_type, psb_ipk_
+      Implicit None
+      class(amg_d_ainv_solver_type), intent(inout)              :: sv
+      class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_d_ainv_solver_clone_settings
+  end interface
 
   interface
     subroutine amg_d_ainv_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)

amgprec/amg_d_invk_solver.f90

@@ -52,6 +52,7 @@ module amg_d_invk_solver
   contains
     procedure, pass(sv) :: check   => amg_d_invk_solver_check
     procedure, pass(sv) :: clone   => amg_d_invk_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_d_invk_solver_clone_settings
     procedure, pass(sv) :: build   => amg_d_invk_solver_bld
     procedure, pass(sv) :: cseti   => amg_d_invk_solver_cseti
     procedure, pass(sv) :: descr   => amg_d_invk_solver_descr
@@ -73,6 +74,17 @@ module amg_d_invk_solver
     end subroutine amg_d_invk_solver_clone
   end interface
 
+  interface
+    subroutine amg_d_invk_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+       & amg_d_base_solver_type, psb_dpk_, amg_d_invk_solver_type, psb_ipk_
+      Implicit None
+      class(amg_d_invk_solver_type), intent(inout)              :: sv
+      class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_d_invk_solver_clone_settings
+  end interface
+
   interface
     subroutine amg_d_invk_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &

amgprec/amg_d_invt_solver.f90

@@ -52,6 +52,7 @@ module amg_d_invt_solver
   contains
     procedure, pass(sv) :: check   => amg_d_invt_solver_check
     procedure, pass(sv) :: clone   => amg_d_invt_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_d_invt_solver_clone_settings
     procedure, pass(sv) :: build   => amg_d_invt_solver_bld
     procedure, pass(sv) :: cseti   => amg_d_invt_solver_cseti
     procedure, pass(sv) :: csetr   => amg_d_invt_solver_csetr
@@ -73,6 +74,17 @@ module amg_d_invt_solver
     end subroutine amg_d_invt_solver_clone
   end interface
 
+  interface
+    subroutine amg_d_invt_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+       & amg_d_base_solver_type, psb_dpk_, amg_d_invt_solver_type, psb_ipk_
+      Implicit None
+      class(amg_d_invt_solver_type), intent(inout)              :: sv
+      class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_d_invt_solver_clone_settings
+  end interface
+
   interface
     subroutine amg_d_invt_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &

amgprec/amg_d_jac_solver.f90

@@ -0,0 +1,582 @@
+!  
+!   
+!                             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_d_jac_solver_mod.f90
+!
+! Module: amg_d_jac_solver_mod
+!
+!  This module defines: 
+!  - the amg_d_jac_solver_type data structure containing the ingredients
+!    for a local Jacobi  iteration. The iterations are local to a process
+!    (they operate on the block diagonal).
+!    
+!
+module amg_d_jac_solver
+
+  use amg_d_base_solver_mod
+
+  type, extends(amg_d_base_solver_type) :: amg_d_jac_solver_type
+    type(psb_dspmat_type)      :: a
+    type(psb_d_vect_type), allocatable :: dv
+    real(psb_dpk_), allocatable        :: d(:)
+    integer(psb_ipk_)          :: sweeps
+    real(psb_dpk_)             :: eps
+  contains
+    procedure, pass(sv) :: dump    => amg_d_jac_solver_dmp
+    procedure, pass(sv) :: check   => d_jac_solver_check
+    procedure, pass(sv) :: clone   => amg_d_jac_solver_clone
+    procedure, pass(sv) :: clone_settings => amg_d_jac_solver_clone_settings
+    procedure, pass(sv) :: clear_data     => amg_d_jac_solver_clear_data
+    procedure, pass(sv) :: build   => amg_d_jac_solver_bld
+    procedure, pass(sv) :: cnv     => amg_d_jac_solver_cnv
+    procedure, pass(sv) :: apply_v => amg_d_jac_solver_apply_vect
+    procedure, pass(sv) :: apply_a => amg_d_jac_solver_apply
+    procedure, pass(sv) :: free    => d_jac_solver_free
+    procedure, pass(sv) :: cseti   => d_jac_solver_cseti
+    procedure, pass(sv) :: csetc   => d_jac_solver_csetc
+    procedure, pass(sv) :: csetr   => d_jac_solver_csetr
+    procedure, pass(sv) :: descr   => d_jac_solver_descr
+    procedure, pass(sv) :: default => d_jac_solver_default
+    procedure, pass(sv) :: sizeof  => d_jac_solver_sizeof
+    procedure, pass(sv) :: get_nzeros => d_jac_solver_get_nzeros
+    procedure, nopass   :: get_wrksz  => d_jac_solver_get_wrksize
+    procedure, nopass   :: get_fmt    => d_jac_solver_get_fmt
+    procedure, nopass   :: get_id     => d_jac_solver_get_id
+    procedure, nopass   :: is_iterative => d_jac_solver_is_iterative
+  end type amg_d_jac_solver_type
+
+  type, extends(amg_d_jac_solver_type) :: amg_d_l1_jac_solver_type
+  contains
+    procedure, pass(sv) :: build   => amg_d_l1_jac_solver_bld
+    procedure, pass(sv) :: descr   => d_l1_jac_solver_descr
+    procedure, nopass   :: get_fmt    => d_l1_jac_solver_get_fmt
+    procedure, nopass   :: get_id     => d_l1_jac_solver_get_id
+  end type amg_d_l1_jac_solver_type
+
+
+  private :: d_jac_solver_bld, d_jac_solver_apply, &
+       &  d_jac_solver_free,   &
+       &  d_jac_solver_descr,  d_jac_solver_sizeof, &
+       &  d_jac_solver_default, d_jac_solver_dmp, &
+       &  d_jac_solver_apply_vect, d_jac_solver_get_nzeros, &
+       &  d_jac_solver_get_fmt, d_jac_solver_check,&
+       &  d_jac_solver_is_iterative, &
+       &  d_jac_solver_get_id, d_jac_solver_get_wrksize
+
+  interface 
+    subroutine amg_d_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
+         & trans,work,wv,info,init,initu)
+      import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
+           & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
+      implicit none 
+      type(psb_desc_type), intent(in)             :: desc_data
+      class(amg_d_jac_solver_type), intent(inout) :: sv
+      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
+      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_jac_solver_apply_vect
+  end interface
+
+  interface 
+    subroutine amg_d_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
+      import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
+           & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
+      implicit none 
+      type(psb_desc_type), intent(in)      :: desc_data
+      class(amg_d_jac_solver_type), intent(inout) :: sv
+      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
+      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_jac_solver_apply
+  end interface
+
+  interface 
+    subroutine amg_d_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+      import :: psb_desc_type, amg_d_jac_solver_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
+      implicit none 
+      type(psb_dspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a 
+      class(amg_d_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      type(psb_dspmat_type), intent(in), target, optional :: b
+      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_jac_solver_bld
+  end interface
+
+  interface 
+    subroutine amg_d_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+      import :: psb_desc_type, amg_d_l1_jac_solver_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
+      implicit none 
+      type(psb_dspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a 
+      class(amg_d_l1_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      type(psb_dspmat_type), intent(in), target, optional :: b
+      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_l1_jac_solver_bld
+  end interface
+
+  interface 
+    subroutine amg_d_jac_solver_cnv(sv,info,amold,vmold,imold)
+      import :: amg_d_jac_solver_type, psb_dpk_, &
+           & psb_d_base_sparse_mat, psb_d_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      implicit none 
+      class(amg_d_jac_solver_type), intent(inout)         :: sv
+      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_jac_solver_cnv
+  end interface
+  
+  interface 
+    subroutine amg_d_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
+      import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
+           & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, &
+           & psb_ipk_
+      implicit none 
+      class(amg_d_jac_solver_type), intent(in) :: sv
+      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)              :: solver, global_num
+    end subroutine amg_d_jac_solver_dmp
+  end interface
+  
+  interface
+    subroutine amg_d_jac_solver_clone(sv,svout,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
+           & amg_d_base_solver_type, amg_d_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_d_jac_solver_type), intent(inout)               :: sv
+      class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)              :: info
+    end subroutine amg_d_jac_solver_clone
+  end interface
+  
+!!$  interface
+!!$    subroutine amg_d_l1_jac_solver_clone(sv,svout,info)
+!!$      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+!!$           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
+!!$           & amg_d_base_solver_type, amg_d_l1_jac_solver_type, psb_ipk_
+!!$      Implicit None
+!!$      
+!!$      ! Arguments
+!!$      class(amg_d_l1_jac_solver_type), intent(inout)               :: sv
+!!$      class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
+!!$      integer(psb_ipk_), intent(out)              :: info
+!!$    end subroutine amg_d_l1_jac_solver_clone
+!!$  end interface
+
+  interface
+    subroutine amg_d_jac_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
+           & amg_d_base_solver_type, amg_d_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_d_jac_solver_type), intent(inout) :: sv
+      class(amg_d_base_solver_type), intent(inout) :: svout
+      integer(psb_ipk_), intent(out)               :: info
+    end subroutine amg_d_jac_solver_clone_settings
+  end interface
+
+  interface
+    subroutine amg_d_jac_solver_clear_data(sv,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
+           & amg_d_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_d_jac_solver_type), intent(inout) :: sv
+      integer(psb_ipk_), intent(out)                 :: info
+    end subroutine amg_d_jac_solver_clear_data
+  end interface
+
+contains
+
+  subroutine d_jac_solver_default(sv)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_jac_solver_type), intent(inout) :: sv
+
+    sv%sweeps = ione
+    sv%eps    = dzero
+    
+    return
+  end subroutine d_jac_solver_default
+
+  subroutine d_jac_solver_check(sv,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_jac_solver_type), intent(inout) :: sv
+    integer(psb_ipk_), intent(out)                :: info
+    integer(psb_ipk_) :: err_act
+    character(len=20) :: name='d_jac_solver_check'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call amg_check_def(sv%sweeps,&
+         & 'Jacobi sweeps',ione,is_int_positive)
+
+    if (info /= psb_success_) goto 9999
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine d_jac_solver_check
+
+  subroutine d_jac_solver_cseti(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_jac_solver_type), intent(inout) :: sv 
+    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_jac_solver_cseti'
+
+    info = psb_success_
+    call psb_erractionsave(err_act)
+
+    select case(psb_toupper(what))
+    case('SOLVER_SWEEPS')
+      sv%sweeps = val      
+    case default
+      call sv%amg_d_base_solver_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 d_jac_solver_cseti
+
+  subroutine d_jac_solver_csetc(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_jac_solver_type), intent(inout) :: sv
+    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_jac_solver_csetc'
+
+    info = psb_success_
+    call psb_erractionsave(err_act)
+
+
+    call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
+  
+    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 d_jac_solver_csetc
+  
+  subroutine d_jac_solver_csetr(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_jac_solver_type), intent(inout) :: sv 
+    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_jac_solver_csetr'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    select case(psb_toupper(what))
+    case('SOLVER_EPS') 
+      sv%eps = val
+    case default
+      call sv%amg_d_base_solver_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 d_jac_solver_csetr
+
+  subroutine d_jac_solver_free(sv,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_jac_solver_type), intent(inout) :: sv
+    integer(psb_ipk_), intent(out)                :: info
+    integer(psb_ipk_)  :: err_act
+    character(len=20)  :: name='d_jac_solver_free'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call sv%a%free()
+    call sv%dv%free(info)
+    if (allocated(sv%d)) deallocate(sv%d)
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine d_jac_solver_free
+
+  subroutine d_jac_solver_descr(sv,info,iout,coarse,prefix)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_jac_solver_type), intent(in) :: sv
+    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_jac_solver_descr'
+    integer(psb_ipk_) :: iout_
+    character(1024)    :: prefix_
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+    if (present(iout)) then 
+      iout_ = iout 
+    else
+      iout_ = psb_out_unit
+    endif
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if (sv%eps<=dzero) then 
+      write(iout_,*) trim(prefix_), '  Jacobi iterative solver with  ',&
+           &  sv%sweeps,' sweeps'
+    else
+      write(iout_,*) trim(prefix_), '  Jacobi iterative solver with  tolerance',&
+           &  sv%eps,' and maxit', sv%sweeps
+    end if
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine d_jac_solver_descr
+
+  function d_jac_solver_get_nzeros(sv) result(val)
+
+    implicit none 
+    ! Arguments
+    class(amg_d_jac_solver_type), intent(in) :: sv
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+    
+    val = 0 
+    val = val + sv%a%get_nzeros()
+    val = val + sv%dv%get_nrows()
+
+    return
+  end function d_jac_solver_get_nzeros
+
+  function d_jac_solver_sizeof(sv) result(val)
+
+    implicit none 
+    ! Arguments
+    class(amg_d_jac_solver_type), intent(in) :: sv
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+
+    val = psb_sizeof_ip 
+    val = val + sv%a%sizeof()
+    val = val + sv%dv%sizeof()
+
+    return
+  end function d_jac_solver_sizeof
+
+  function d_jac_solver_get_fmt() result(val)
+    implicit none 
+    character(len=32)  :: val
+
+    val = "Jacobi solver"
+  end function d_jac_solver_get_fmt
+
+  function d_jac_solver_get_id() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = amg_jac_
+  end function d_jac_solver_get_id
+
+  !
+  ! If this is true, then the solver needs a starting
+  ! guess. Currently only handled in JAC smoother. 
+  ! 
+  function d_jac_solver_is_iterative() result(val)
+    implicit none 
+    logical  :: val
+
+    val = .true.
+  end function d_jac_solver_is_iterative
+    
+  function d_jac_solver_get_wrksize() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = 2
+  end function d_jac_solver_get_wrksize
+
+  subroutine d_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_l1_jac_solver_type), intent(in) :: sv
+    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_l1_jac_solver_descr'
+    integer(psb_ipk_) :: iout_
+    character(1024)    :: prefix_
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+    if (present(iout)) then 
+      iout_ = iout 
+    else
+      iout_ = psb_out_unit
+    endif
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if (sv%eps<=dzero) then 
+      write(iout_,*) trim(prefix_), '  L1-Jacobi iterative solver with  ',&
+           &  sv%sweeps,' sweeps'
+    else
+      write(iout_,*) trim(prefix_), '  L1-Jacobi iterative solver with  tolerance',&
+           &  sv%eps,' and maxit', sv%sweeps
+    end if
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine d_l1_jac_solver_descr
+
+  function d_l1_jac_solver_get_fmt() result(val)
+    implicit none 
+    character(len=32)  :: val
+
+    val = "L1-Jacobi solver"
+  end function d_l1_jac_solver_get_fmt
+
+  function d_l1_jac_solver_get_id() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = amg_l1_jac_
+  end function d_l1_jac_solver_get_id
+  
+end module amg_d_jac_solver

amgprec/amg_d_matchboxp_mod.f90

@@ -143,9 +143,10 @@ contains
     type(psb_ld_coo_sparse_mat) :: tmpcoo
     logical  :: display_out_, print_out_, reproducible_
     logical, parameter  :: dump=.false., debug=.false., dump_mate=.false., &
-         & debug_ilaggr=.false., debug_sync=.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.
+    integer, parameter :: ilaggr_neginit=-1, ilaggr_nonlocal=-2
 
     ictxt = desc_a%get_ctxt()
     call psb_info(ictxt,iam,np)
@@ -187,7 +188,7 @@ contains
     call desc_a%l2gip(ilv,info,owned=.false.)
 
     call psb_geall(ilaggr,desc_a,info)
-    ilaggr = -1
+    ilaggr = ilaggr_neginit
     call psb_geasb(ilaggr,desc_a,info)
     nr = a%get_nrows()
     nc = a%get_ncols()
@@ -213,7 +214,20 @@ contains
       call psb_barrier(ictxt)
       if (iam == 0) write(0,*)' out from buildmatching:', info
     end if
-
+    if (debug_mate) then
+      block
+        integer(psb_lpk_), allocatable :: ckmate(:)
+        allocate(ckmate(nr))
+        ckmate(1:nr) = mate(1:nr)
+        call psb_msort(ckmate(1:nr))
+        do i=1,nr-1
+          if ((ckmate(i)>0) .and. (ckmate(i) == ckmate(i+1))) then
+            write(0,*) iam,' Duplicate mate entry  at',i,' :',ckmate(i)
+          end if
+        end do
+      end block
+    end if
+     
     if (info == 0) then
       if (do_timings) call psb_tic(idx_phase2)
       if (debug_sync) then
@@ -259,7 +273,7 @@ contains
           cycle
         else
 
-          if (ilaggr(k) == -1) then
+          if (ilaggr(k) == ilaggr_neginit) then
 
             wk   = w(k)
             widx = w(idx)
@@ -267,7 +281,7 @@ contains
             nrmagg = wmax*sqrt((wk/wmax)**2+(widx/wmax)**2)
             if (nrmagg > epsilon(nrmagg)) then
               if (idx <= nr) then
-                if (ilaggr(idx) == -1) then
+                if (ilaggr(idx) == ilaggr_neginit) then
                   ! Now, if both vertices are local, the aggregate is local
                   ! (kinda obvious).
                   nlaggr(iam) = nlaggr(iam) + 1
@@ -275,6 +289,9 @@ contains
                   ilaggr(idx) = nlaggr(iam)
                   wtemp(k)    = w(k)/nrmagg
                   wtemp(idx)  = w(idx)/nrmagg
+                else
+                  write(0,*) iam,' Inconsistent mate? ',k,mate(k),idx,&
+                       &mate(idx),ilaggr(idx)
                 end if
                 nlpairs = nlpairs+1
               else if (idx <= nc) then
@@ -294,7 +311,7 @@ contains
                     ilaggr(k)   = nlaggr(iam)
                     nlpairs = nlpairs+1
                   else
-                    ilaggr(k) = -2
+                    ilaggr(k) = ilaggr_nonlocal
                   end if
                 else
                   ! Use a statistically unbiased tie-breaking rule,
@@ -309,7 +326,7 @@ contains
                     ilaggr(k)   = nlaggr(iam)
                     nlpairs = nlpairs+1
                   else
-                    ilaggr(k) = -2
+                    ilaggr(k) = ilaggr_nonlocal
                   end if
                 end if
               end if
@@ -325,6 +342,12 @@ contains
                 nlsingl     = nlsingl + 1
               end if
             end if
+            if (ilaggr(k) == ilaggr_neginit) then
+              write(0,*) iam,' Error: no update to ',k,mate(k),&
+                   & abs(w(k)),nrmagg,epsilon(nrmagg),wtemp(k)
+            end if
+          else
+            if (ilaggr(k)<0) write(0,*) 'Strange? ',k,ilaggr(k)
           end if
         end if
       end do
@@ -332,7 +355,7 @@ contains
       if (do_timings) call psb_tic(idx_phase3)
 
       ! Ok, now compute offsets, gather halo and fix non-local
-      ! aggregates  (those where ilaggr == -2)
+      ! aggregates  (those where ilaggr == ilaggr_nonlocal)
       call psb_sum(ictxt,nlaggr)
       ntaggr  = sum(nlaggr(0:np-1))
       naggrm1 = sum(nlaggr(0:iam-1))
@@ -347,7 +370,7 @@ contains
       call psb_halo(wtemp,desc_a,info)
       ! Cleanup as yet unmarked entries
       do k=1,nr
-        if (ilaggr(k) == -2) then
+        if (ilaggr(k) == ilaggr_nonlocal) then
           idx = mate(k)
           if (idx > nr) then
             i   = ilaggr(idx)
@@ -359,9 +382,14 @@ contains
           else
             write(0,*) 'Error : unresolved (paired) index ',k,idx,i,nr,nc, ilv(k),ilv(idx)
           end if
-        end if
-        if (ilaggr(k) <0) then
-          write(0,*) 'Matchboxp: Funny number: ',k,ilv(k),ilaggr(k),wtemp(k)
+        else if (ilaggr(k) <0) then
+          write(0,*) iam,'Matchboxp: Funny number: ',k,ilv(k),ilaggr(k),wtemp(k)
+          write(0,*) iam,'         :             : ',nr,nc,mate(k)
+          if (mate(k) <= nr) then
+            write(0,*) iam,'         :             : ',ilaggr(mate(k)),mate(mate(k)),&
+                 & ilv(k),ilv(mate(k)), ilv(mate(mate(k))),ilaggr(mate(mate(k)))
+          end if
+          flush(0)
         end if
       end do
       if (debug_sync) then
@@ -414,7 +442,7 @@ contains
 
       end block
       if (iam == 0) then
-        write(0,*) 'Matching statistics: Unmatched nodes ',&
+        write(0,*) iam,'Matching statistics: Unmatched nodes ',&
              & nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs
       end if
 

amgprec/amg_d_mumps_solver.F90

@@ -78,7 +78,8 @@ module amg_d_mumps_solver
     !
     ! Controls to be set before MUMPS instantiation:
     !
-    ! IPAR(1) : MUMPS_LOC_GLOB   0==amg_local_solver_: LOCAL   1==amg_global_solver_: GLOBAL
+    ! IPAR(1) : MUMPS_LOC_GLOB   0==amg_local_solver_: 'LOCAL_SOLVER
+    !                            1==amg_global_solver_: 'GLOBAL_SOLVER'
     ! IPAR(2) : MUMPS_PRINT_ERR  print verbosity (see MUMPS)
     ! IPAR(3) : MUMPS_SYM        0: non-symmetric   2: symmetric
     integer(psb_ipk_), dimension(3) :: ipar

amgprec/amg_s_ainv_solver.F90

@@ -58,6 +58,7 @@ module amg_s_ainv_solver
     procedure, pass(sv) :: check   => amg_s_ainv_solver_check
     procedure, pass(sv) :: build   => amg_s_ainv_solver_bld
     procedure, pass(sv) :: clone   => amg_s_ainv_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_s_ainv_solver_clone_settings
     procedure, pass(sv) :: cseti   => amg_s_ainv_solver_cseti
     procedure, pass(sv) :: csetc   => amg_s_ainv_solver_csetc
     procedure, pass(sv) :: csetr   => amg_s_ainv_solver_csetr
@@ -85,6 +86,16 @@ module amg_s_ainv_solver
     end subroutine amg_s_ainv_solver_clone
   end interface
 
+  interface
+    subroutine amg_s_ainv_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+       & amg_s_base_solver_type, psb_dpk_, amg_s_ainv_solver_type, psb_ipk_
+      Implicit None
+      class(amg_s_ainv_solver_type), intent(inout)              :: sv
+      class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_s_ainv_solver_clone_settings
+  end interface
 
   interface
     subroutine amg_s_ainv_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)

amgprec/amg_s_invk_solver.f90

@@ -52,6 +52,7 @@ module amg_s_invk_solver
   contains
     procedure, pass(sv) :: check   => amg_s_invk_solver_check
     procedure, pass(sv) :: clone   => amg_s_invk_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_s_invk_solver_clone_settings
     procedure, pass(sv) :: build   => amg_s_invk_solver_bld
     procedure, pass(sv) :: cseti   => amg_s_invk_solver_cseti
     procedure, pass(sv) :: descr   => amg_s_invk_solver_descr
@@ -73,6 +74,17 @@ module amg_s_invk_solver
     end subroutine amg_s_invk_solver_clone
   end interface
 
+  interface
+    subroutine amg_s_invk_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+       & amg_s_base_solver_type, psb_spk_, amg_s_invk_solver_type, psb_ipk_
+      Implicit None
+      class(amg_s_invk_solver_type), intent(inout)              :: sv
+      class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_s_invk_solver_clone_settings
+  end interface
+
   interface
     subroutine amg_s_invk_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &

amgprec/amg_s_invt_solver.f90

@@ -52,6 +52,7 @@ module amg_s_invt_solver
   contains
     procedure, pass(sv) :: check   => amg_s_invt_solver_check
     procedure, pass(sv) :: clone   => amg_s_invt_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_s_invt_solver_clone_settings
     procedure, pass(sv) :: build   => amg_s_invt_solver_bld
     procedure, pass(sv) :: cseti   => amg_s_invt_solver_cseti
     procedure, pass(sv) :: csetr   => amg_s_invt_solver_csetr
@@ -73,6 +74,17 @@ module amg_s_invt_solver
     end subroutine amg_s_invt_solver_clone
   end interface
 
+  interface
+    subroutine amg_s_invt_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+       & amg_s_base_solver_type, psb_spk_, amg_s_invt_solver_type, psb_ipk_
+      Implicit None
+      class(amg_s_invt_solver_type), intent(inout)              :: sv
+      class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_s_invt_solver_clone_settings
+  end interface
+
   interface
     subroutine amg_s_invt_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &

amgprec/amg_s_jac_solver.f90

@@ -0,0 +1,582 @@
+!  
+!   
+!                             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_s_jac_solver_mod.f90
+!
+! Module: amg_s_jac_solver_mod
+!
+!  This module defines: 
+!  - the amg_s_jac_solver_type data structure containing the ingredients
+!    for a local Jacobi  iteration. The iterations are local to a process
+!    (they operate on the block diagonal).
+!    
+!
+module amg_s_jac_solver
+
+  use amg_s_base_solver_mod
+
+  type, extends(amg_s_base_solver_type) :: amg_s_jac_solver_type
+    type(psb_sspmat_type)      :: a
+    type(psb_s_vect_type), allocatable :: dv
+    real(psb_spk_), allocatable        :: d(:)
+    integer(psb_ipk_)          :: sweeps
+    real(psb_spk_)             :: eps
+  contains
+    procedure, pass(sv) :: dump    => amg_s_jac_solver_dmp
+    procedure, pass(sv) :: check   => s_jac_solver_check
+    procedure, pass(sv) :: clone   => amg_s_jac_solver_clone
+    procedure, pass(sv) :: clone_settings => amg_s_jac_solver_clone_settings
+    procedure, pass(sv) :: clear_data     => amg_s_jac_solver_clear_data
+    procedure, pass(sv) :: build   => amg_s_jac_solver_bld
+    procedure, pass(sv) :: cnv     => amg_s_jac_solver_cnv
+    procedure, pass(sv) :: apply_v => amg_s_jac_solver_apply_vect
+    procedure, pass(sv) :: apply_a => amg_s_jac_solver_apply
+    procedure, pass(sv) :: free    => s_jac_solver_free
+    procedure, pass(sv) :: cseti   => s_jac_solver_cseti
+    procedure, pass(sv) :: csetc   => s_jac_solver_csetc
+    procedure, pass(sv) :: csetr   => s_jac_solver_csetr
+    procedure, pass(sv) :: descr   => s_jac_solver_descr
+    procedure, pass(sv) :: default => s_jac_solver_default
+    procedure, pass(sv) :: sizeof  => s_jac_solver_sizeof
+    procedure, pass(sv) :: get_nzeros => s_jac_solver_get_nzeros
+    procedure, nopass   :: get_wrksz  => s_jac_solver_get_wrksize
+    procedure, nopass   :: get_fmt    => s_jac_solver_get_fmt
+    procedure, nopass   :: get_id     => s_jac_solver_get_id
+    procedure, nopass   :: is_iterative => s_jac_solver_is_iterative
+  end type amg_s_jac_solver_type
+
+  type, extends(amg_s_jac_solver_type) :: amg_s_l1_jac_solver_type
+  contains
+    procedure, pass(sv) :: build   => amg_s_l1_jac_solver_bld
+    procedure, pass(sv) :: descr   => s_l1_jac_solver_descr
+    procedure, nopass   :: get_fmt    => s_l1_jac_solver_get_fmt
+    procedure, nopass   :: get_id     => s_l1_jac_solver_get_id
+  end type amg_s_l1_jac_solver_type
+
+
+  private :: s_jac_solver_bld, s_jac_solver_apply, &
+       &  s_jac_solver_free,   &
+       &  s_jac_solver_descr,  s_jac_solver_sizeof, &
+       &  s_jac_solver_default, s_jac_solver_dmp, &
+       &  s_jac_solver_apply_vect, s_jac_solver_get_nzeros, &
+       &  s_jac_solver_get_fmt, s_jac_solver_check,&
+       &  s_jac_solver_is_iterative, &
+       &  s_jac_solver_get_id, s_jac_solver_get_wrksize
+
+  interface 
+    subroutine amg_s_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
+         & trans,work,wv,info,init,initu)
+      import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
+           & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
+      implicit none 
+      type(psb_desc_type), intent(in)             :: desc_data
+      class(amg_s_jac_solver_type), intent(inout) :: sv
+      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
+      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_jac_solver_apply_vect
+  end interface
+
+  interface 
+    subroutine amg_s_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
+      import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
+           & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
+      implicit none 
+      type(psb_desc_type), intent(in)      :: desc_data
+      class(amg_s_jac_solver_type), intent(inout) :: sv
+      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
+      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_jac_solver_apply
+  end interface
+
+  interface 
+    subroutine amg_s_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+      import :: psb_desc_type, amg_s_jac_solver_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
+      implicit none 
+      type(psb_sspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a 
+      class(amg_s_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      type(psb_sspmat_type), intent(in), target, optional :: b
+      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_jac_solver_bld
+  end interface
+
+  interface 
+    subroutine amg_s_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+      import :: psb_desc_type, amg_s_l1_jac_solver_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
+      implicit none 
+      type(psb_sspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a 
+      class(amg_s_l1_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      type(psb_sspmat_type), intent(in), target, optional :: b
+      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_l1_jac_solver_bld
+  end interface
+
+  interface 
+    subroutine amg_s_jac_solver_cnv(sv,info,amold,vmold,imold)
+      import :: amg_s_jac_solver_type, psb_spk_, &
+           & psb_s_base_sparse_mat, psb_s_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      implicit none 
+      class(amg_s_jac_solver_type), intent(inout)         :: sv
+      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_jac_solver_cnv
+  end interface
+  
+  interface 
+    subroutine amg_s_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
+      import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
+           & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, &
+           & psb_ipk_
+      implicit none 
+      class(amg_s_jac_solver_type), intent(in) :: sv
+      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)              :: solver, global_num
+    end subroutine amg_s_jac_solver_dmp
+  end interface
+  
+  interface
+    subroutine amg_s_jac_solver_clone(sv,svout,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
+           & amg_s_base_solver_type, amg_s_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_s_jac_solver_type), intent(inout)               :: sv
+      class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)              :: info
+    end subroutine amg_s_jac_solver_clone
+  end interface
+  
+!!$  interface
+!!$    subroutine amg_s_l1_jac_solver_clone(sv,svout,info)
+!!$      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+!!$           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
+!!$           & amg_s_base_solver_type, amg_s_l1_jac_solver_type, psb_ipk_
+!!$      Implicit None
+!!$      
+!!$      ! Arguments
+!!$      class(amg_s_l1_jac_solver_type), intent(inout)               :: sv
+!!$      class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
+!!$      integer(psb_ipk_), intent(out)              :: info
+!!$    end subroutine amg_s_l1_jac_solver_clone
+!!$  end interface
+
+  interface
+    subroutine amg_s_jac_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
+           & amg_s_base_solver_type, amg_s_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_s_jac_solver_type), intent(inout) :: sv
+      class(amg_s_base_solver_type), intent(inout) :: svout
+      integer(psb_ipk_), intent(out)               :: info
+    end subroutine amg_s_jac_solver_clone_settings
+  end interface
+
+  interface
+    subroutine amg_s_jac_solver_clear_data(sv,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
+           & amg_s_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_s_jac_solver_type), intent(inout) :: sv
+      integer(psb_ipk_), intent(out)                 :: info
+    end subroutine amg_s_jac_solver_clear_data
+  end interface
+
+contains
+
+  subroutine s_jac_solver_default(sv)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_jac_solver_type), intent(inout) :: sv
+
+    sv%sweeps = ione
+    sv%eps    = dzero
+    
+    return
+  end subroutine s_jac_solver_default
+
+  subroutine s_jac_solver_check(sv,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_jac_solver_type), intent(inout) :: sv
+    integer(psb_ipk_), intent(out)                :: info
+    integer(psb_ipk_) :: err_act
+    character(len=20) :: name='s_jac_solver_check'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call amg_check_def(sv%sweeps,&
+         & 'Jacobi sweeps',ione,is_int_positive)
+
+    if (info /= psb_success_) goto 9999
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine s_jac_solver_check
+
+  subroutine s_jac_solver_cseti(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_jac_solver_type), intent(inout) :: sv 
+    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='s_jac_solver_cseti'
+
+    info = psb_success_
+    call psb_erractionsave(err_act)
+
+    select case(psb_toupper(what))
+    case('SOLVER_SWEEPS')
+      sv%sweeps = val      
+    case default
+      call sv%amg_s_base_solver_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 s_jac_solver_cseti
+
+  subroutine s_jac_solver_csetc(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_jac_solver_type), intent(inout) :: sv
+    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='s_jac_solver_csetc'
+
+    info = psb_success_
+    call psb_erractionsave(err_act)
+
+
+    call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
+  
+    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 s_jac_solver_csetc
+  
+  subroutine s_jac_solver_csetr(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_jac_solver_type), intent(inout) :: sv 
+    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='s_jac_solver_csetr'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    select case(psb_toupper(what))
+    case('SOLVER_EPS') 
+      sv%eps = val
+    case default
+      call sv%amg_s_base_solver_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 s_jac_solver_csetr
+
+  subroutine s_jac_solver_free(sv,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_jac_solver_type), intent(inout) :: sv
+    integer(psb_ipk_), intent(out)                :: info
+    integer(psb_ipk_)  :: err_act
+    character(len=20)  :: name='s_jac_solver_free'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call sv%a%free()
+    call sv%dv%free(info)
+    if (allocated(sv%d)) deallocate(sv%d)
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine s_jac_solver_free
+
+  subroutine s_jac_solver_descr(sv,info,iout,coarse,prefix)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_jac_solver_type), intent(in) :: sv
+    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_jac_solver_descr'
+    integer(psb_ipk_) :: iout_
+    character(1024)    :: prefix_
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+    if (present(iout)) then 
+      iout_ = iout 
+    else
+      iout_ = psb_out_unit
+    endif
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if (sv%eps<=dzero) then 
+      write(iout_,*) trim(prefix_), '  Jacobi iterative solver with  ',&
+           &  sv%sweeps,' sweeps'
+    else
+      write(iout_,*) trim(prefix_), '  Jacobi iterative solver with  tolerance',&
+           &  sv%eps,' and maxit', sv%sweeps
+    end if
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine s_jac_solver_descr
+
+  function s_jac_solver_get_nzeros(sv) result(val)
+
+    implicit none 
+    ! Arguments
+    class(amg_s_jac_solver_type), intent(in) :: sv
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+    
+    val = 0 
+    val = val + sv%a%get_nzeros()
+    val = val + sv%dv%get_nrows()
+
+    return
+  end function s_jac_solver_get_nzeros
+
+  function s_jac_solver_sizeof(sv) result(val)
+
+    implicit none 
+    ! Arguments
+    class(amg_s_jac_solver_type), intent(in) :: sv
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+
+    val = psb_sizeof_ip 
+    val = val + sv%a%sizeof()
+    val = val + sv%dv%sizeof()
+
+    return
+  end function s_jac_solver_sizeof
+
+  function s_jac_solver_get_fmt() result(val)
+    implicit none 
+    character(len=32)  :: val
+
+    val = "Jacobi solver"
+  end function s_jac_solver_get_fmt
+
+  function s_jac_solver_get_id() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = amg_jac_
+  end function s_jac_solver_get_id
+
+  !
+  ! If this is true, then the solver needs a starting
+  ! guess. Currently only handled in JAC smoother. 
+  ! 
+  function s_jac_solver_is_iterative() result(val)
+    implicit none 
+    logical  :: val
+
+    val = .true.
+  end function s_jac_solver_is_iterative
+    
+  function s_jac_solver_get_wrksize() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = 2
+  end function s_jac_solver_get_wrksize
+
+  subroutine s_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_l1_jac_solver_type), intent(in) :: sv
+    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_l1_jac_solver_descr'
+    integer(psb_ipk_) :: iout_
+    character(1024)    :: prefix_
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+    if (present(iout)) then 
+      iout_ = iout 
+    else
+      iout_ = psb_out_unit
+    endif
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if (sv%eps<=dzero) then 
+      write(iout_,*) trim(prefix_), '  L1-Jacobi iterative solver with  ',&
+           &  sv%sweeps,' sweeps'
+    else
+      write(iout_,*) trim(prefix_), '  L1-Jacobi iterative solver with  tolerance',&
+           &  sv%eps,' and maxit', sv%sweeps
+    end if
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine s_l1_jac_solver_descr
+
+  function s_l1_jac_solver_get_fmt() result(val)
+    implicit none 
+    character(len=32)  :: val
+
+    val = "L1-Jacobi solver"
+  end function s_l1_jac_solver_get_fmt
+
+  function s_l1_jac_solver_get_id() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = amg_l1_jac_
+  end function s_l1_jac_solver_get_id
+  
+end module amg_s_jac_solver

amgprec/amg_s_matchboxp_mod.f90

@@ -143,9 +143,10 @@ contains
     type(psb_ls_coo_sparse_mat) :: tmpcoo
     logical  :: display_out_, print_out_, reproducible_
     logical, parameter  :: dump=.false., debug=.false., dump_mate=.false., &
-         & debug_ilaggr=.false., debug_sync=.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.
+    integer, parameter :: ilaggr_neginit=-1, ilaggr_nonlocal=-2
 
     ictxt = desc_a%get_ctxt()
     call psb_info(ictxt,iam,np)
@@ -187,7 +188,7 @@ contains
     call desc_a%l2gip(ilv,info,owned=.false.)
 
     call psb_geall(ilaggr,desc_a,info)
-    ilaggr = -1
+    ilaggr = ilaggr_neginit
     call psb_geasb(ilaggr,desc_a,info)
     nr = a%get_nrows()
     nc = a%get_ncols()
@@ -213,7 +214,20 @@ contains
       call psb_barrier(ictxt)
       if (iam == 0) write(0,*)' out from buildmatching:', info
     end if
-
+    if (debug_mate) then
+      block
+        integer(psb_lpk_), allocatable :: ckmate(:)
+        allocate(ckmate(nr))
+        ckmate(1:nr) = mate(1:nr)
+        call psb_msort(ckmate(1:nr))
+        do i=1,nr-1
+          if ((ckmate(i)>0) .and. (ckmate(i) == ckmate(i+1))) then
+            write(0,*) iam,' Duplicate mate entry  at',i,' :',ckmate(i)
+          end if
+        end do
+      end block
+    end if
+     
     if (info == 0) then
       if (do_timings) call psb_tic(idx_phase2)
       if (debug_sync) then
@@ -259,7 +273,7 @@ contains
           cycle
         else
 
-          if (ilaggr(k) == -1) then
+          if (ilaggr(k) == ilaggr_neginit) then
 
             wk   = w(k)
             widx = w(idx)
@@ -267,7 +281,7 @@ contains
             nrmagg = wmax*sqrt((wk/wmax)**2+(widx/wmax)**2)
             if (nrmagg > epsilon(nrmagg)) then
               if (idx <= nr) then
-                if (ilaggr(idx) == -1) then
+                if (ilaggr(idx) == ilaggr_neginit) then
                   ! Now, if both vertices are local, the aggregate is local
                   ! (kinda obvious).
                   nlaggr(iam) = nlaggr(iam) + 1
@@ -275,6 +289,9 @@ contains
                   ilaggr(idx) = nlaggr(iam)
                   wtemp(k)    = w(k)/nrmagg
                   wtemp(idx)  = w(idx)/nrmagg
+                else
+                  write(0,*) iam,' Inconsistent mate? ',k,mate(k),idx,&
+                       &mate(idx),ilaggr(idx)
                 end if
                 nlpairs = nlpairs+1
               else if (idx <= nc) then
@@ -294,7 +311,7 @@ contains
                     ilaggr(k)   = nlaggr(iam)
                     nlpairs = nlpairs+1
                   else
-                    ilaggr(k) = -2
+                    ilaggr(k) = ilaggr_nonlocal
                   end if
                 else
                   ! Use a statistically unbiased tie-breaking rule,
@@ -309,7 +326,7 @@ contains
                     ilaggr(k)   = nlaggr(iam)
                     nlpairs = nlpairs+1
                   else
-                    ilaggr(k) = -2
+                    ilaggr(k) = ilaggr_nonlocal
                   end if
                 end if
               end if
@@ -325,6 +342,12 @@ contains
                 nlsingl     = nlsingl + 1
               end if
             end if
+            if (ilaggr(k) == ilaggr_neginit) then
+              write(0,*) iam,' Error: no update to ',k,mate(k),&
+                   & abs(w(k)),nrmagg,epsilon(nrmagg),wtemp(k)
+            end if
+          else
+            if (ilaggr(k)<0) write(0,*) 'Strange? ',k,ilaggr(k)
           end if
         end if
       end do
@@ -332,7 +355,7 @@ contains
       if (do_timings) call psb_tic(idx_phase3)
 
       ! Ok, now compute offsets, gather halo and fix non-local
-      ! aggregates  (those where ilaggr == -2)
+      ! aggregates  (those where ilaggr == ilaggr_nonlocal)
       call psb_sum(ictxt,nlaggr)
       ntaggr  = sum(nlaggr(0:np-1))
       naggrm1 = sum(nlaggr(0:iam-1))
@@ -347,7 +370,7 @@ contains
       call psb_halo(wtemp,desc_a,info)
       ! Cleanup as yet unmarked entries
       do k=1,nr
-        if (ilaggr(k) == -2) then
+        if (ilaggr(k) == ilaggr_nonlocal) then
           idx = mate(k)
           if (idx > nr) then
             i   = ilaggr(idx)
@@ -359,9 +382,14 @@ contains
           else
             write(0,*) 'Error : unresolved (paired) index ',k,idx,i,nr,nc, ilv(k),ilv(idx)
           end if
-        end if
-        if (ilaggr(k) <0) then
-          write(0,*) 'Matchboxp: Funny number: ',k,ilv(k),ilaggr(k),wtemp(k)
+        else if (ilaggr(k) <0) then
+          write(0,*) iam,'Matchboxp: Funny number: ',k,ilv(k),ilaggr(k),wtemp(k)
+          write(0,*) iam,'         :             : ',nr,nc,mate(k)
+          if (mate(k) <= nr) then
+            write(0,*) iam,'         :             : ',ilaggr(mate(k)),mate(mate(k)),&
+                 & ilv(k),ilv(mate(k)), ilv(mate(mate(k))),ilaggr(mate(mate(k)))
+          end if
+          flush(0)
         end if
       end do
       if (debug_sync) then
@@ -414,7 +442,7 @@ contains
 
       end block
       if (iam == 0) then
-        write(0,*) 'Matching statistics: Unmatched nodes ',&
+        write(0,*) iam,'Matching statistics: Unmatched nodes ',&
              & nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs
       end if
 

amgprec/amg_s_mumps_solver.F90

@@ -78,7 +78,8 @@ module amg_s_mumps_solver
     !
     ! Controls to be set before MUMPS instantiation:
     !
-    ! IPAR(1) : MUMPS_LOC_GLOB   0==amg_local_solver_: LOCAL   1==amg_global_solver_: GLOBAL
+    ! IPAR(1) : MUMPS_LOC_GLOB   0==amg_local_solver_: 'LOCAL_SOLVER
+    !                            1==amg_global_solver_: 'GLOBAL_SOLVER'
     ! IPAR(2) : MUMPS_PRINT_ERR  print verbosity (see MUMPS)
     ! IPAR(3) : MUMPS_SYM        0: non-symmetric   2: symmetric
     integer(psb_ipk_), dimension(3) :: ipar

amgprec/amg_z_ainv_solver.F90

@@ -58,6 +58,7 @@ module amg_z_ainv_solver
     procedure, pass(sv) :: check   => amg_z_ainv_solver_check
     procedure, pass(sv) :: build   => amg_z_ainv_solver_bld
     procedure, pass(sv) :: clone   => amg_z_ainv_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_z_ainv_solver_clone_settings
     procedure, pass(sv) :: cseti   => amg_z_ainv_solver_cseti
     procedure, pass(sv) :: csetc   => amg_z_ainv_solver_csetc
     procedure, pass(sv) :: csetr   => amg_z_ainv_solver_csetr
@@ -85,6 +86,16 @@ module amg_z_ainv_solver
     end subroutine amg_z_ainv_solver_clone
   end interface
 
+  interface
+    subroutine amg_z_ainv_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+       & amg_z_base_solver_type, psb_dpk_, amg_z_ainv_solver_type, psb_ipk_
+      Implicit None
+      class(amg_z_ainv_solver_type), intent(inout)              :: sv
+      class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_z_ainv_solver_clone_settings
+  end interface
 
   interface
     subroutine amg_z_ainv_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)

amgprec/amg_z_invk_solver.f90

@@ -52,6 +52,7 @@ module amg_z_invk_solver
   contains
     procedure, pass(sv) :: check   => amg_z_invk_solver_check
     procedure, pass(sv) :: clone   => amg_z_invk_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_z_invk_solver_clone_settings
     procedure, pass(sv) :: build   => amg_z_invk_solver_bld
     procedure, pass(sv) :: cseti   => amg_z_invk_solver_cseti
     procedure, pass(sv) :: descr   => amg_z_invk_solver_descr
@@ -73,6 +74,17 @@ module amg_z_invk_solver
     end subroutine amg_z_invk_solver_clone
   end interface
 
+  interface
+    subroutine amg_z_invk_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+       & amg_z_base_solver_type, psb_dpk_, amg_z_invk_solver_type, psb_ipk_
+      Implicit None
+      class(amg_z_invk_solver_type), intent(inout)              :: sv
+      class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_z_invk_solver_clone_settings
+  end interface
+
   interface
     subroutine amg_z_invk_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &

amgprec/amg_z_invt_solver.f90

@@ -52,6 +52,7 @@ module amg_z_invt_solver
   contains
     procedure, pass(sv) :: check   => amg_z_invt_solver_check
     procedure, pass(sv) :: clone   => amg_z_invt_solver_clone
+    procedure, pass(sv) :: clone_settings   => amg_z_invt_solver_clone_settings
     procedure, pass(sv) :: build   => amg_z_invt_solver_bld
     procedure, pass(sv) :: cseti   => amg_z_invt_solver_cseti
     procedure, pass(sv) :: csetr   => amg_z_invt_solver_csetr
@@ -73,6 +74,17 @@ module amg_z_invt_solver
     end subroutine amg_z_invt_solver_clone
   end interface
 
+  interface
+    subroutine amg_z_invt_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+       & amg_z_base_solver_type, psb_dpk_, amg_z_invt_solver_type, psb_ipk_
+      Implicit None
+      class(amg_z_invt_solver_type), intent(inout)              :: sv
+      class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)                            :: info
+    end subroutine amg_z_invt_solver_clone_settings
+  end interface
+
   interface
     subroutine amg_z_invt_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &

amgprec/amg_z_jac_solver.f90

@@ -0,0 +1,582 @@
+!  
+!   
+!                             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_z_jac_solver_mod.f90
+!
+! Module: amg_z_jac_solver_mod
+!
+!  This module defines: 
+!  - the amg_z_jac_solver_type data structure containing the ingredients
+!    for a local Jacobi  iteration. The iterations are local to a process
+!    (they operate on the block diagonal).
+!    
+!
+module amg_z_jac_solver
+
+  use amg_z_base_solver_mod
+
+  type, extends(amg_z_base_solver_type) :: amg_z_jac_solver_type
+    type(psb_zspmat_type)      :: a
+    type(psb_z_vect_type), allocatable :: dv
+    complex(psb_dpk_), allocatable        :: d(:)
+    integer(psb_ipk_)          :: sweeps
+    real(psb_dpk_)             :: eps
+  contains
+    procedure, pass(sv) :: dump    => amg_z_jac_solver_dmp
+    procedure, pass(sv) :: check   => z_jac_solver_check
+    procedure, pass(sv) :: clone   => amg_z_jac_solver_clone
+    procedure, pass(sv) :: clone_settings => amg_z_jac_solver_clone_settings
+    procedure, pass(sv) :: clear_data     => amg_z_jac_solver_clear_data
+    procedure, pass(sv) :: build   => amg_z_jac_solver_bld
+    procedure, pass(sv) :: cnv     => amg_z_jac_solver_cnv
+    procedure, pass(sv) :: apply_v => amg_z_jac_solver_apply_vect
+    procedure, pass(sv) :: apply_a => amg_z_jac_solver_apply
+    procedure, pass(sv) :: free    => z_jac_solver_free
+    procedure, pass(sv) :: cseti   => z_jac_solver_cseti
+    procedure, pass(sv) :: csetc   => z_jac_solver_csetc
+    procedure, pass(sv) :: csetr   => z_jac_solver_csetr
+    procedure, pass(sv) :: descr   => z_jac_solver_descr
+    procedure, pass(sv) :: default => z_jac_solver_default
+    procedure, pass(sv) :: sizeof  => z_jac_solver_sizeof
+    procedure, pass(sv) :: get_nzeros => z_jac_solver_get_nzeros
+    procedure, nopass   :: get_wrksz  => z_jac_solver_get_wrksize
+    procedure, nopass   :: get_fmt    => z_jac_solver_get_fmt
+    procedure, nopass   :: get_id     => z_jac_solver_get_id
+    procedure, nopass   :: is_iterative => z_jac_solver_is_iterative
+  end type amg_z_jac_solver_type
+
+  type, extends(amg_z_jac_solver_type) :: amg_z_l1_jac_solver_type
+  contains
+    procedure, pass(sv) :: build   => amg_z_l1_jac_solver_bld
+    procedure, pass(sv) :: descr   => z_l1_jac_solver_descr
+    procedure, nopass   :: get_fmt    => z_l1_jac_solver_get_fmt
+    procedure, nopass   :: get_id     => z_l1_jac_solver_get_id
+  end type amg_z_l1_jac_solver_type
+
+
+  private :: z_jac_solver_bld, z_jac_solver_apply, &
+       &  z_jac_solver_free,   &
+       &  z_jac_solver_descr,  z_jac_solver_sizeof, &
+       &  z_jac_solver_default, z_jac_solver_dmp, &
+       &  z_jac_solver_apply_vect, z_jac_solver_get_nzeros, &
+       &  z_jac_solver_get_fmt, z_jac_solver_check,&
+       &  z_jac_solver_is_iterative, &
+       &  z_jac_solver_get_id, z_jac_solver_get_wrksize
+
+  interface 
+    subroutine amg_z_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
+         & trans,work,wv,info,init,initu)
+      import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
+           & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
+      implicit none 
+      type(psb_desc_type), intent(in)             :: desc_data
+      class(amg_z_jac_solver_type), intent(inout) :: sv
+      type(psb_z_vect_type),intent(inout)         :: x
+      type(psb_z_vect_type),intent(inout)         :: y
+      complex(psb_dpk_),intent(in)                    :: alpha,beta
+      character(len=1),intent(in)                   :: trans
+      complex(psb_dpk_),target, intent(inout)         :: work(:)
+      type(psb_z_vect_type),intent(inout)         :: wv(:)
+      integer(psb_ipk_), intent(out)                :: info
+      character, intent(in), optional                :: init
+      type(psb_z_vect_type),intent(inout), optional   :: initu
+    end subroutine amg_z_jac_solver_apply_vect
+  end interface
+
+  interface 
+    subroutine amg_z_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
+      import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
+           & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
+      implicit none 
+      type(psb_desc_type), intent(in)      :: desc_data
+      class(amg_z_jac_solver_type), intent(inout) :: sv
+      complex(psb_dpk_),intent(inout)         :: x(:)
+      complex(psb_dpk_),intent(inout)         :: y(:)
+      complex(psb_dpk_),intent(in)            :: alpha,beta
+      character(len=1),intent(in)           :: trans
+      complex(psb_dpk_),target, intent(inout) :: work(:)
+      integer(psb_ipk_), intent(out)        :: info
+      character, intent(in), optional       :: init
+      complex(psb_dpk_),intent(inout), optional :: initu(:)
+    end subroutine amg_z_jac_solver_apply
+  end interface
+
+  interface 
+    subroutine amg_z_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+      import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
+           & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      implicit none 
+      type(psb_zspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a 
+      class(amg_z_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      type(psb_zspmat_type), intent(in), target, optional :: b
+      class(psb_z_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_z_base_vect_type), intent(in), optional   :: vmold
+      class(psb_i_base_vect_type), intent(in), optional   :: imold
+    end subroutine amg_z_jac_solver_bld
+  end interface
+
+  interface 
+    subroutine amg_z_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+      import :: psb_desc_type, amg_z_l1_jac_solver_type, psb_z_vect_type, psb_dpk_, &
+           & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      implicit none 
+      type(psb_zspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a 
+      class(amg_z_l1_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      type(psb_zspmat_type), intent(in), target, optional :: b
+      class(psb_z_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_z_base_vect_type), intent(in), optional   :: vmold
+      class(psb_i_base_vect_type), intent(in), optional   :: imold
+    end subroutine amg_z_l1_jac_solver_bld
+  end interface
+
+  interface 
+    subroutine amg_z_jac_solver_cnv(sv,info,amold,vmold,imold)
+      import :: amg_z_jac_solver_type, psb_dpk_, &
+           & psb_z_base_sparse_mat, psb_z_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      implicit none 
+      class(amg_z_jac_solver_type), intent(inout)         :: sv
+      integer(psb_ipk_), intent(out)                      :: info
+      class(psb_z_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_z_base_vect_type), intent(in), optional   :: vmold
+      class(psb_i_base_vect_type), intent(in), optional   :: imold
+    end subroutine amg_z_jac_solver_cnv
+  end interface
+  
+  interface 
+    subroutine amg_z_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
+      import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
+           & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, &
+           & psb_ipk_
+      implicit none 
+      class(amg_z_jac_solver_type), intent(in) :: sv
+      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)              :: solver, global_num
+    end subroutine amg_z_jac_solver_dmp
+  end interface
+  
+  interface
+    subroutine amg_z_jac_solver_clone(sv,svout,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
+           & amg_z_base_solver_type, amg_z_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_z_jac_solver_type), intent(inout)               :: sv
+      class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
+      integer(psb_ipk_), intent(out)              :: info
+    end subroutine amg_z_jac_solver_clone
+  end interface
+  
+!!$  interface
+!!$    subroutine amg_z_l1_jac_solver_clone(sv,svout,info)
+!!$      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+!!$           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
+!!$           & amg_z_base_solver_type, amg_z_l1_jac_solver_type, psb_ipk_
+!!$      Implicit None
+!!$      
+!!$      ! Arguments
+!!$      class(amg_z_l1_jac_solver_type), intent(inout)               :: sv
+!!$      class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
+!!$      integer(psb_ipk_), intent(out)              :: info
+!!$    end subroutine amg_z_l1_jac_solver_clone
+!!$  end interface
+
+  interface
+    subroutine amg_z_jac_solver_clone_settings(sv,svout,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
+           & amg_z_base_solver_type, amg_z_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_z_jac_solver_type), intent(inout) :: sv
+      class(amg_z_base_solver_type), intent(inout) :: svout
+      integer(psb_ipk_), intent(out)               :: info
+    end subroutine amg_z_jac_solver_clone_settings
+  end interface
+
+  interface
+    subroutine amg_z_jac_solver_clear_data(sv,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
+           & amg_z_jac_solver_type, psb_ipk_
+      Implicit None
+      
+      ! Arguments
+      class(amg_z_jac_solver_type), intent(inout) :: sv
+      integer(psb_ipk_), intent(out)                 :: info
+    end subroutine amg_z_jac_solver_clear_data
+  end interface
+
+contains
+
+  subroutine z_jac_solver_default(sv)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_z_jac_solver_type), intent(inout) :: sv
+
+    sv%sweeps = ione
+    sv%eps    = dzero
+    
+    return
+  end subroutine z_jac_solver_default
+
+  subroutine z_jac_solver_check(sv,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_z_jac_solver_type), intent(inout) :: sv
+    integer(psb_ipk_), intent(out)                :: info
+    integer(psb_ipk_) :: err_act
+    character(len=20) :: name='z_jac_solver_check'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call amg_check_def(sv%sweeps,&
+         & 'Jacobi sweeps',ione,is_int_positive)
+
+    if (info /= psb_success_) goto 9999
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine z_jac_solver_check
+
+  subroutine z_jac_solver_cseti(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_z_jac_solver_type), intent(inout) :: sv 
+    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='z_jac_solver_cseti'
+
+    info = psb_success_
+    call psb_erractionsave(err_act)
+
+    select case(psb_toupper(what))
+    case('SOLVER_SWEEPS')
+      sv%sweeps = val      
+    case default
+      call sv%amg_z_base_solver_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 z_jac_solver_cseti
+
+  subroutine z_jac_solver_csetc(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_z_jac_solver_type), intent(inout) :: sv
+    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='z_jac_solver_csetc'
+
+    info = psb_success_
+    call psb_erractionsave(err_act)
+
+
+    call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
+  
+    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 z_jac_solver_csetc
+  
+  subroutine z_jac_solver_csetr(sv,what,val,info,idx)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_z_jac_solver_type), intent(inout) :: sv 
+    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='z_jac_solver_csetr'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    select case(psb_toupper(what))
+    case('SOLVER_EPS') 
+      sv%eps = val
+    case default
+      call sv%amg_z_base_solver_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 z_jac_solver_csetr
+
+  subroutine z_jac_solver_free(sv,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_z_jac_solver_type), intent(inout) :: sv
+    integer(psb_ipk_), intent(out)                :: info
+    integer(psb_ipk_)  :: err_act
+    character(len=20)  :: name='z_jac_solver_free'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call sv%a%free()
+    call sv%dv%free(info)
+    if (allocated(sv%d)) deallocate(sv%d)
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine z_jac_solver_free
+
+  subroutine z_jac_solver_descr(sv,info,iout,coarse,prefix)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_z_jac_solver_type), intent(in) :: sv
+    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_z_jac_solver_descr'
+    integer(psb_ipk_) :: iout_
+    character(1024)    :: prefix_
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+    if (present(iout)) then 
+      iout_ = iout 
+    else
+      iout_ = psb_out_unit
+    endif
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if (sv%eps<=dzero) then 
+      write(iout_,*) trim(prefix_), '  Jacobi iterative solver with  ',&
+           &  sv%sweeps,' sweeps'
+    else
+      write(iout_,*) trim(prefix_), '  Jacobi iterative solver with  tolerance',&
+           &  sv%eps,' and maxit', sv%sweeps
+    end if
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine z_jac_solver_descr
+
+  function z_jac_solver_get_nzeros(sv) result(val)
+
+    implicit none 
+    ! Arguments
+    class(amg_z_jac_solver_type), intent(in) :: sv
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+    
+    val = 0 
+    val = val + sv%a%get_nzeros()
+    val = val + sv%dv%get_nrows()
+
+    return
+  end function z_jac_solver_get_nzeros
+
+  function z_jac_solver_sizeof(sv) result(val)
+
+    implicit none 
+    ! Arguments
+    class(amg_z_jac_solver_type), intent(in) :: sv
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+
+    val = psb_sizeof_ip 
+    val = val + sv%a%sizeof()
+    val = val + sv%dv%sizeof()
+
+    return
+  end function z_jac_solver_sizeof
+
+  function z_jac_solver_get_fmt() result(val)
+    implicit none 
+    character(len=32)  :: val
+
+    val = "Jacobi solver"
+  end function z_jac_solver_get_fmt
+
+  function z_jac_solver_get_id() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = amg_jac_
+  end function z_jac_solver_get_id
+
+  !
+  ! If this is true, then the solver needs a starting
+  ! guess. Currently only handled in JAC smoother. 
+  ! 
+  function z_jac_solver_is_iterative() result(val)
+    implicit none 
+    logical  :: val
+
+    val = .true.
+  end function z_jac_solver_is_iterative
+    
+  function z_jac_solver_get_wrksize() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = 2
+  end function z_jac_solver_get_wrksize
+
+  subroutine z_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_z_l1_jac_solver_type), intent(in) :: sv
+    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_z_l1_jac_solver_descr'
+    integer(psb_ipk_) :: iout_
+    character(1024)    :: prefix_
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+    if (present(iout)) then 
+      iout_ = iout 
+    else
+      iout_ = psb_out_unit
+    endif
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if (sv%eps<=dzero) then 
+      write(iout_,*) trim(prefix_), '  L1-Jacobi iterative solver with  ',&
+           &  sv%sweeps,' sweeps'
+    else
+      write(iout_,*) trim(prefix_), '  L1-Jacobi iterative solver with  tolerance',&
+           &  sv%eps,' and maxit', sv%sweeps
+    end if
+    
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine z_l1_jac_solver_descr
+
+  function z_l1_jac_solver_get_fmt() result(val)
+    implicit none 
+    character(len=32)  :: val
+
+    val = "L1-Jacobi solver"
+  end function z_l1_jac_solver_get_fmt
+
+  function z_l1_jac_solver_get_id() result(val)
+    implicit none 
+    integer(psb_ipk_)  :: val
+
+    val = amg_l1_jac_
+  end function z_l1_jac_solver_get_id
+  
+end module amg_z_jac_solver

amgprec/amg_z_mumps_solver.F90

@@ -78,7 +78,8 @@ module amg_z_mumps_solver
     !
     ! Controls to be set before MUMPS instantiation:
     !
-    ! IPAR(1) : MUMPS_LOC_GLOB   0==amg_local_solver_: LOCAL   1==amg_global_solver_: GLOBAL
+    ! IPAR(1) : MUMPS_LOC_GLOB   0==amg_local_solver_: 'LOCAL_SOLVER
+    !                            1==amg_global_solver_: 'GLOBAL_SOLVER'
     ! IPAR(2) : MUMPS_PRINT_ERR  print verbosity (see MUMPS)
     ! IPAR(3) : MUMPS_SYM        0: non-symmetric   2: symmetric
     integer(psb_ipk_), dimension(3) :: ipar

amgprec/impl/aggregator/Makefile

@@ -62,7 +62,22 @@ amg_s_parmatch_smth_bld.o \
 amg_s_parmatch_spmm_bld_inner.o
 
 MPCOBJS=MatchBoxPC.o \
-algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.o
+sendBundledMessages.o \
+initialize.o \
+extractUChunk.o \
+isAlreadyMatched.o \
+findOwnerOfGhost.o \
+clean.o \
+computeCandidateMate.o \
+parallelComputeCandidateMateB.o \
+processMatchedVertices.o \
+processMatchedVerticesAndSendMessages.o \
+processCrossEdge.o \
+queueTransfer.o \
+processMessages.o \
+processExposedVertex.o \
+algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.o \
+algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.o
 
 OBJS = $(FOBJS) $(MPCOBJS)
 

amgprec/impl/aggregator/MatchBoxPC.cpp

@@ -60,17 +60,43 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
 		MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
 #if !defined(SERIAL_MPI)
   MPI_Comm C_comm=MPI_Comm_f2c(icomm);
+
 #ifdef DEBUG
   fprintf(stderr,"MatchBoxPC: rank %d nlver %ld nledge %ld [ %ld %ld ]\n",
 	  myRank,NLVer, NLEdge,verDistance[0],verDistance[1]);
 #endif
-  dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(NLVer, NLEdge,
+
+
+#define TIME_TRACKER
+    #ifdef TIME_TRACKER
+        double tmr = MPI_Wtime();
+    #endif
+
+#define OMP
+#ifdef OMP
+        dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(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
+        dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(NLVer, NLEdge,
+							   verLocPtr, verLocInd, edgeLocWeight,
+							   verDistance,  Mate,
+							   myRank, numProcs, C_comm,
+							   msgIndSent, msgActualSent, msgPercent,
+							   ph0_time, ph1_time, ph2_time,
+							   ph1_card, ph2_card );
+#endif
+
+
+  #ifdef TIME_TRACKER
+    tmr = MPI_Wtime() - tmr;
+    fprintf(stderr, "Elaboration time: %f for %ld nodes\n", tmr, NLVer);
+  #endif
+
 #endif
 }
 

amgprec/impl/aggregator/MatchBoxPC.h

@@ -52,145 +52,412 @@
 
 #ifndef _matchboxpC_H_
 #define _matchboxpC_H_
-//Turn on a lot of debugging information with this switch:
+// Turn on a lot of debugging information with this switch:
 //#define PRINT_DEBUG_INFO_
 #include <stdio.h>
 #include <iostream>
 #include <assert.h>
 #include <map>
 #include <vector>
-// #include "matchboxp.h"
+#include "omp.h"
 #include "primitiveDataTypeDefinitions.h"
 #include "dataStrStaticQueue.h"
 
 using namespace std;
 
+const int NUM_THREAD = 4;
+const int UCHUNK = 10;
+
+const MilanLongInt REQUEST = 1;
+const MilanLongInt SUCCESS = 2;
+const MilanLongInt FAILURE = 3;
+const MilanLongInt SIZEINFO = 4;
+
+const int ComputeTag = 7; // Predefined tag
+const int BundleTag = 9;  // Predefined tag
+
+static vector<MilanLongInt> DEFAULT_VECTOR;
+
+// MPI type map
+template <typename T>
+MPI_Datatype TypeMap();
+template <>
+inline MPI_Datatype TypeMap<int64_t>() { return MPI_LONG_LONG; }
+template <>
+inline MPI_Datatype TypeMap<int>() { return MPI_INT; }
+template <>
+inline MPI_Datatype TypeMap<double>() { return MPI_DOUBLE; }
+template <>
+inline MPI_Datatype TypeMap<float>() { return MPI_FLOAT; }
+
 #ifdef __cplusplus
-extern "C" {
+extern "C"
+{
 #endif
 
 #if !defined(SERIAL_MPI)
-  
-#define MilanMpiLongInt  MPI_LONG_LONG
+
+#define MilanMpiLongInt MPI_LONG_LONG
 
 #ifndef _primitiveDataType_Definition_
 #define _primitiveDataType_Definition_
-    //Regular integer:
-    #ifndef INTEGER_H
-    #define INTEGER_H
-        typedef int32_t MilanInt;
-    #endif
+// Regular integer:
+#ifndef INTEGER_H
+#define INTEGER_H
+    typedef int32_t MilanInt;
+#endif
 
-    //Regular long integer:
-    #ifndef LONG_INT_H
-    #define LONG_INT_H
-        #ifdef BIT64
-            typedef int64_t MilanLongInt;
-            typedef MPI_LONG MilanMpiLongInt;
-        #else
-            typedef int32_t MilanLongInt;
-            typedef MPI_INT MilanMpiLongInt;
-        #endif
-    #endif
+// Regular long integer:
+#ifndef LONG_INT_H
+#define LONG_INT_H
+#ifdef BIT64
+    typedef int64_t MilanLongInt;
+    typedef MPI_LONG MilanMpiLongInt;
+#else
+    typedef int32_t MilanLongInt;
+    typedef MPI_INT MilanMpiLongInt;
+#endif
+#endif
 
-    //Regular boolean
-    #ifndef BOOL_H
-    #define BOOL_H
-        typedef bool MilanBool;
-    #endif
+// Regular boolean
+#ifndef BOOL_H
+#define BOOL_H
+    typedef bool MilanBool;
+#endif
 
-    //Regular double and absolute value computation:
-    #ifndef REAL_H
-    #define REAL_H
-        typedef double MilanReal;
-        typedef MPI_DOUBLE MilanMpiReal;
-        inline MilanReal MilanAbs(MilanReal value)
-        {
-            return fabs(value);
-        }
-    #endif
+// Regular double and absolute value computation:
+#ifndef REAL_H
+#define REAL_H
+    typedef double MilanReal;
+    typedef MPI_DOUBLE MilanMpiReal;
+    inline MilanReal MilanAbs(MilanReal value)
+    {
+        return fabs(value);
+    }
+#endif
 
-    //Regular float and absolute value computation:
-    #ifndef FLOAT_H
-    #define FLOAT_H
-        typedef float MilanFloat;
-        typedef MPI_FLOAT MilanMpiFloat;
-        inline MilanFloat MilanAbsFloat(MilanFloat value)
-        {
-            return fabs(value);
-        }
-    #endif
+// Regular float and absolute value computation:
+#ifndef FLOAT_H
+#define FLOAT_H
+    typedef float MilanFloat;
+    typedef MPI_FLOAT MilanMpiFloat;
+    inline MilanFloat MilanAbsFloat(MilanFloat value)
+    {
+        return fabs(value);
+    }
+#endif
 
-    //// Define the limits:
-    #ifndef LIMITS_H
-    #define LIMITS_H
-    //Integer Maximum and Minimum:
-  //      #define MilanIntMax INT_MAX
-  //    #define MilanIntMin INT_MIN
-        #define MilanIntMax INT32_MAX
-        #define MilanIntMin INT32_MIN
+//// Define the limits:
+#ifndef LIMITS_H
+#define LIMITS_H
+    // Integer Maximum and Minimum:
+    //      #define MilanIntMax INT_MAX
+    //    #define MilanIntMin INT_MIN
+#define MilanIntMax INT32_MAX
+#define MilanIntMin INT32_MIN
 
-        #ifdef BIT64
-            #define MilanLongIntMax INT64_MAX
-            #define MilanLongIntMin -INT64_MAX
-        #else
-            #define MilanLongIntMax INT32_MAX
-            #define MilanLongIntMin -INT32_MAX
-        #endif
+#ifdef BIT64
+#define MilanLongIntMax INT64_MAX
+#define MilanLongIntMin -INT64_MAX
+#else
+#define MilanLongIntMax INT32_MAX
+#define MilanLongIntMin -INT32_MAX
+#endif
 
-    #endif
+#endif
 
     // +INFINITY
     const double PLUS_INFINITY = numeric_limits<int>::infinity();
     const double MINUS_INFINITY = -PLUS_INFINITY;
-    //#define MilanRealMax LDBL_MAX
-    #define MilanRealMax PLUS_INFINITY
-    #define MilanRealMin MINUS_INFINITY
+//#define MilanRealMax LDBL_MAX
+#define MilanRealMax PLUS_INFINITY
+#define MilanRealMin MINUS_INFINITY
 #endif
 
-//Function of find the owner of a ghost vertex using binary search:
-inline MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
-                                     MilanInt myRank, MilanInt numProcs);
+    // Function of find the owner of a ghost vertex using binary search:
+    MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
+                              MilanInt myRank, MilanInt numProcs);
 
-  void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC
-(
- 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 );
+    MilanLongInt firstComputeCandidateMate(MilanLongInt adj1,
+                                           MilanLongInt adj2,
+                                           MilanLongInt *verLocInd,
+                                           MilanReal *edgeLocWeight);
 
- 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 );
+    void queuesTransfer(vector<MilanLongInt> &U,
+                        vector<MilanLongInt> &privateU,
+                        vector<MilanLongInt> &QLocalVtx,
+                        vector<MilanLongInt> &QGhostVtx,
+                        vector<MilanLongInt> &QMsgType,
+                        vector<MilanInt> &QOwner,
+                        vector<MilanLongInt> &privateQLocalVtx,
+                        vector<MilanLongInt> &privateQGhostVtx,
+                        vector<MilanLongInt> &privateQMsgType,
+                        vector<MilanInt> &privateQOwner);
 
-void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
-		MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanReal* edgeLocWeight,
-		MilanLongInt* verDistance,
-		MilanLongInt* Mate,
-		MilanInt myRank, MilanInt numProcs, MilanInt icomm,
-		MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
-		MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
-		MilanLongInt* ph1_card, MilanLongInt* ph2_card );
+    bool isAlreadyMatched(MilanLongInt node,
+                          MilanLongInt StartIndex,
+                          MilanLongInt EndIndex,
+                          vector<MilanLongInt> &GMate,
+                          MilanLongInt *Mate,
+                          map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
 
-void sMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
-		MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanFloat* edgeLocWeight,
-		MilanLongInt* verDistance,
-		MilanLongInt* Mate,
-		MilanInt myRank, MilanInt numProcs, MilanInt icomm,
-		MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
-		MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
-		MilanLongInt* ph1_card, MilanLongInt* ph2_card );
+    MilanLongInt computeCandidateMate(MilanLongInt adj1,
+                                      MilanLongInt adj2,
+                                      MilanReal *edgeLocWeight,
+                                      MilanLongInt k,
+                                      MilanLongInt *verLocInd,
+                                      MilanLongInt StartIndex,
+                                      MilanLongInt EndIndex,
+                                      vector<MilanLongInt> &GMate,
+                                      MilanLongInt *Mate,
+                                      map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
+
+    void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
+                    MilanLongInt StartIndex, MilanLongInt EndIndex,
+                    MilanLongInt *numGhostEdgesPtr,
+                    MilanLongInt *numGhostVerticesPtr,
+                    MilanLongInt *S,
+                    MilanLongInt *verLocInd,
+                    MilanLongInt *verLocPtr,
+                    map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+                    vector<MilanLongInt> &Counter,
+                    vector<MilanLongInt> &verGhostPtr,
+                    vector<MilanLongInt> &verGhostInd,
+                    vector<MilanLongInt> &tempCounter,
+                    vector<MilanLongInt> &GMate,
+                    vector<MilanLongInt> &Message,
+                    vector<MilanLongInt> &QLocalVtx,
+                    vector<MilanLongInt> &QGhostVtx,
+                    vector<MilanLongInt> &QMsgType,
+                    vector<MilanInt> &QOwner,
+                    MilanLongInt *&candidateMate,
+                    vector<MilanLongInt> &U,
+                    vector<MilanLongInt> &privateU,
+                    vector<MilanLongInt> &privateQLocalVtx,
+                    vector<MilanLongInt> &privateQGhostVtx,
+                    vector<MilanLongInt> &privateQMsgType,
+                    vector<MilanInt> &privateQOwner);
+
+    void clean(MilanLongInt NLVer,
+               MilanInt myRank,
+               MilanLongInt MessageIndex,
+               vector<MPI_Request> &SRequest,
+               vector<MPI_Status> &SStatus,
+               MilanInt BufferSize,
+               MilanLongInt *Buffer,
+               MilanLongInt msgActual,
+               MilanLongInt *msgActualSent,
+               MilanLongInt msgInd,
+               MilanLongInt *msgIndSent,
+               MilanLongInt NumMessagesBundled,
+               MilanReal *msgPercent);
+
+    void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer,
+                                           MilanLongInt *verLocPtr,
+                                           MilanLongInt *verLocInd,
+                                           MilanInt myRank,
+                                           MilanReal *edgeLocWeight,
+                                           MilanLongInt *candidateMate);
+
+    void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer,
+                                           MilanLongInt *candidateMate,
+                                           MilanLongInt *verLocInd,
+                                           MilanLongInt *verLocPtr,
+                                           MilanLongInt StartIndex,
+                                           MilanLongInt EndIndex,
+                                           MilanLongInt *Mate,
+                                           vector<MilanLongInt> &GMate,
+                                           map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+                                           MilanReal *edgeLocWeight,
+                                           MilanLongInt *myCardPtr,
+                                           MilanLongInt *msgIndPtr,
+                                           MilanLongInt *NumMessagesBundledPtr,
+                                           MilanLongInt *SPtr,
+                                           MilanLongInt *verDistance,
+                                           MilanLongInt *PCounter,
+                                           vector<MilanLongInt> &Counter,
+                                           MilanInt myRank,
+                                           MilanInt numProcs,
+                                           vector<MilanLongInt> &U,
+                                           vector<MilanLongInt> &privateU,
+                                           vector<MilanLongInt> &QLocalVtx,
+                                           vector<MilanLongInt> &QGhostVtx,
+                                           vector<MilanLongInt> &QMsgType,
+                                           vector<MilanInt> &QOwner,
+                                           vector<MilanLongInt> &privateQLocalVtx,
+                                           vector<MilanLongInt> &privateQGhostVtx,
+                                           vector<MilanLongInt> &privateQMsgType,
+                                           vector<MilanInt> &privateQOwner);
+
+    void PROCESS_CROSS_EDGE(MilanLongInt *edge,
+                            MilanLongInt *SPtr);
+
+    void processMatchedVertices(
+        MilanLongInt NLVer,
+        vector<MilanLongInt> &UChunkBeingProcessed,
+        vector<MilanLongInt> &U,
+        vector<MilanLongInt> &privateU,
+        MilanLongInt StartIndex,
+        MilanLongInt EndIndex,
+        MilanLongInt *myCardPtr,
+        MilanLongInt *msgIndPtr,
+        MilanLongInt *NumMessagesBundledPtr,
+        MilanLongInt *SPtr,
+        MilanLongInt *verLocPtr,
+        MilanLongInt *verLocInd,
+        MilanLongInt *verDistance,
+        MilanLongInt *PCounter,
+        vector<MilanLongInt> &Counter,
+        MilanInt myRank,
+        MilanInt numProcs,
+        MilanLongInt *candidateMate,
+        vector<MilanLongInt> &GMate,
+        MilanLongInt *Mate,
+        map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+        MilanReal *edgeLocWeight,
+        vector<MilanLongInt> &QLocalVtx,
+        vector<MilanLongInt> &QGhostVtx,
+        vector<MilanLongInt> &QMsgType,
+        vector<MilanInt> &QOwner,
+        vector<MilanLongInt> &privateQLocalVtx,
+        vector<MilanLongInt> &privateQGhostVtx,
+        vector<MilanLongInt> &privateQMsgType,
+        vector<MilanInt> &privateQOwner);
+
+    void processMatchedVerticesAndSendMessages(
+        MilanLongInt NLVer,
+        vector<MilanLongInt> &UChunkBeingProcessed,
+        vector<MilanLongInt> &U,
+        vector<MilanLongInt> &privateU,
+        MilanLongInt StartIndex,
+        MilanLongInt EndIndex,
+        MilanLongInt *myCardPtr,
+        MilanLongInt *msgIndPtr,
+        MilanLongInt *NumMessagesBundledPtr,
+        MilanLongInt *SPtr,
+        MilanLongInt *verLocPtr,
+        MilanLongInt *verLocInd,
+        MilanLongInt *verDistance,
+        MilanLongInt *PCounter,
+        vector<MilanLongInt> &Counter,
+        MilanInt myRank,
+        MilanInt numProcs,
+        MilanLongInt *candidateMate,
+        vector<MilanLongInt> &GMate,
+        MilanLongInt *Mate,
+        map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+        MilanReal *edgeLocWeight,
+        vector<MilanLongInt> &QLocalVtx,
+        vector<MilanLongInt> &QGhostVtx,
+        vector<MilanLongInt> &QMsgType,
+        vector<MilanInt> &QOwner,
+        vector<MilanLongInt> &privateQLocalVtx,
+        vector<MilanLongInt> &privateQGhostVtx,
+        vector<MilanLongInt> &privateQMsgType,
+        vector<MilanInt> &privateQOwner,
+        MPI_Comm comm,
+        MilanLongInt *msgActual,
+        vector<MilanLongInt> &Message);
+
+    void sendBundledMessages(MilanLongInt *numGhostEdgesPtr,
+                             MilanInt *BufferSizePtr,
+                             MilanLongInt *Buffer,
+                             vector<MilanLongInt> &PCumulative,
+                             vector<MilanLongInt> &PMessageBundle,
+                             vector<MilanLongInt> &PSizeInfoMessages,
+                             MilanLongInt *PCounter,
+                             MilanLongInt NumMessagesBundled,
+                             MilanLongInt *msgActualPtr,
+                             MilanLongInt *MessageIndexPtr,
+                             MilanInt numProcs,
+                             MilanInt myRank,
+                             MPI_Comm comm,
+                             vector<MilanLongInt> &QLocalVtx,
+                             vector<MilanLongInt> &QGhostVtx,
+                             vector<MilanLongInt> &QMsgType,
+                             vector<MilanInt> &QOwner,
+                             vector<MPI_Request> &SRequest,
+                             vector<MPI_Status> &SStatus);
+
+    void processMessages(
+        MilanLongInt NLVer,
+        MilanLongInt *Mate,
+        MilanLongInt *candidateMate,
+        map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+        vector<MilanLongInt> &GMate,
+        vector<MilanLongInt> &Counter,
+        MilanLongInt StartIndex,
+        MilanLongInt EndIndex,
+        MilanLongInt *myCardPtr,
+        MilanLongInt *msgIndPtr,
+        MilanLongInt *msgActualPtr,
+        MilanReal *edgeLocWeight,
+        MilanLongInt *verDistance,
+        MilanLongInt *verLocPtr,
+        MilanLongInt k,
+        MilanLongInt *verLocInd,
+        MilanInt numProcs,
+        MilanInt myRank,
+        MPI_Comm comm,
+        vector<MilanLongInt> &Message,
+        MilanLongInt numGhostEdges,
+        MilanLongInt u,
+        MilanLongInt v,
+        MilanLongInt *SPtr,
+        vector<MilanLongInt> &U);
+
+    void extractUChunk(
+        vector<MilanLongInt> &UChunkBeingProcessed,
+        vector<MilanLongInt> &U,
+        vector<MilanLongInt> &privateU);
+
+    void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
+        MilanLongInt NLVer, MilanLongInt NLEdge,
+        MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
+        MilanLongInt *verDistance,
+        MilanLongInt *Mate,
+        MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
+        MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
+        MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
+        MilanLongInt *ph1_card, MilanLongInt *ph2_card);
+
+    void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
+        MilanLongInt NLVer, MilanLongInt NLEdge,
+        MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
+        MilanLongInt *verDistance,
+        MilanLongInt *Mate,
+        MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
+        MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
+        MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
+        MilanLongInt *ph1_card, MilanLongInt *ph2_card);
+
+    void 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);
+
+    void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
+                     MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
+                     MilanLongInt *verDistance,
+                     MilanLongInt *Mate,
+                     MilanInt myRank, MilanInt numProcs, MilanInt icomm,
+                     MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
+                     MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
+                     MilanLongInt *ph1_card, MilanLongInt *ph2_card);
+
+    void sMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
+                     MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanFloat *edgeLocWeight,
+                     MilanLongInt *verDistance,
+                     MilanLongInt *Mate,
+                     MilanInt myRank, MilanInt numProcs, MilanInt icomm,
+                     MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
+                     MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
+                     MilanLongInt *ph1_card, MilanLongInt *ph2_card);
 
 #endif
 #ifdef __cplusplus

amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.cpp

@@ -72,12 +72,6 @@
 
 #ifdef SERIAL_MPI
 #else
-//MPI type map
-template<typename T> MPI_Datatype TypeMap();
-template<> inline MPI_Datatype TypeMap<int64_t>() { return MPI_LONG_LONG; }
-template<> inline MPI_Datatype TypeMap<int>() { return MPI_INT; }
-template<> inline MPI_Datatype TypeMap<double>() { return MPI_DOUBLE; }
-template<> inline MPI_Datatype TypeMap<float>() { return MPI_FLOAT; }
 
 // DOUBLE PRECISION VERSION
 //WARNING: The vertex block on a given rank is contiguous

amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp

@@ -0,0 +1,554 @@
+#include "MatchBoxPC.h"
+
+// ***********************************************************************
+//
+//        MatchboxP: A C++ library for approximate weighted matching
+//               Mahantesh Halappanavar (hala@pnnl.gov)
+//               Pacific Northwest National Laboratory
+//
+// ***********************************************************************
+//
+//       Copyright (2021) Battelle Memorial Institute
+//                      All rights reserved.
+//
+// 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. Neither the name of the copyright holder nor the names of its
+// contributors may be used to endorse or promote products derived from
+// this software without specific prior 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
+// COPYRIGHT HOLDER OR 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.
+//
+// ************************************************************************
+//////////////////////////////////////////////////////////////////////////////////////
+/////////////////////////// DOMINATING EDGES MODEL ///////////////////////////////////
+//////////////////////////////////////////////////////////////////////////////////////
+/* Function	: algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMate()
+ *
+ * Date     : New update: Feb 17, 2019, Richland, Washington.
+ * Date		: Original development: May 17, 2009, E&CS Bldg.
+ *
+ * Purpose	: Compute Approximate Maximum Weight Matching in Linear Time
+ *
+ * Args		: inputMatrix - instance of Compressed-Col format of Matrix
+ *                Mate - The Mate array
+ *
+ * Returns	: By Value: (void)
+ *            By Reference: Mate
+ *
+ * Comments	: 1/2 Approx Algorithm. Picks the locally available heaviest edge.
+ *                Assumption: The Mate Array is empty.
+ */
+
+/*
+ NLVer = #of vertices, NLEdge = #of edges
+ CSR/CSC/Compressed format: verLocPtr = Pointer, verLocInd = Index, edgeLocWeight = edge weights (positive real numbers)
+ verDistance = A vector of size |P|+1 containing the cumulative number of vertices per process
+ Mate = A vector of size |V_p| (local subgraph) to store the output (matching)
+ MPI: myRank, numProcs, comm,
+ Statistics: msgIndSent, msgActualSent, msgPercent : Size: |P| number of processes in the comm-world
+ Statistics: ph0_time, ph1_time, ph2_time: Runtimes
+ Statistics: ph1_card, ph2_card : Size: |P| number of processes in the comm-world (number of matched edges in Phase 1 and Phase 2)
+ */
+//#define DEBUG_HANG_
+#ifdef SERIAL_MPI
+#else
+
+// DOUBLE PRECISION VERSION
+// WARNING: The vertex block on a given rank is contiguous
+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)
+{
+
+    /*
+     * verDistance: it's a vector long as the number of processors.
+     *              verDistance[i] contains the first node index of the i-th processor
+     *              verDistance[i + 1] contains the last node index of the i-th processor
+     * NLVer: number of elements in the LocPtr
+     * NLEdge: number of edges assigned to the current processor
+     *
+     * Contains the portion of matrix assigned to the processor in
+     * Yale notation
+     * verLocInd: contains the positions on row of the matrix
+     * verLocPtr: i-th value is the position of the first element on the i-th row and
+     *            i+1-th value is the position of the first element on the i+1-th row
+     */
+
+#if !defined(SERIAL_MPI)
+#ifdef PRINT_DEBUG_INFO_
+    cout << "\n(" << myRank << ")Within algoEdgeApproxDominatingEdgesLinearSearchMessageBundling()";
+    fflush(stdout);
+#endif
+
+#ifdef PRINT_DEBUG_INFO_
+    cout << "\n(" << myRank << ") verDistance [" ;
+    for (int i = 0; i < numProcs; i++)
+      cout << verDistance[i] << "," << verDistance[i+1];
+    cout  << "]\n";
+    fflush(stdout);
+#endif
+#ifdef DEBUG_HANG_
+    if (myRank == 0) {
+      cout << "\n(" << myRank << ") verDistance [" ;
+      for (int i = 0; i < numProcs; i++)
+	cout << verDistance[i] << "," ;
+      cout  << verDistance[numProcs]<< "]\n";
+    }
+    fflush(stdout);
+#endif
+
+    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
+
+    MPI_Status computeStatus;
+
+    MilanLongInt msgActual = 0, msgInd = 0;
+    MilanReal heaviestEdgeWt = 0.0f; // Assumes positive weight
+    MilanReal startTime, finishTime;
+
+    startTime = MPI_Wtime();
+
+    // Data structures for sending and receiving messages:
+    vector<MilanLongInt> Message; // [ u, v, message_type ]
+    Message.resize(3, -1);
+    // Data structures for Message Bundling:
+    // Although up to two messages can be sent along any cross edge,
+    // only one message will be sent in the initialization phase -
+    // one of: REQUEST/FAILURE/SUCCESS
+    vector<MilanLongInt> QLocalVtx, QGhostVtx, QMsgType;
+    vector<MilanInt> QOwner; // Changed by Fabio to be an integer, addresses needs to be integers!
+
+    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
+    MilanInt ghostOwner = 0; // Changed by Fabio to be an integer, addresses needs to be integers!
+    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<MilanLongInt, MilanLongInt> Ghost2LocalMap;       // Map each ghost vertex to a local vertex
+    vector<MilanLongInt> Counter;                         // Store the edge count for each ghost vertex
+    MilanLongInt numGhostVertices = 0, numGhostEdges = 0; // Number of Ghost vertices
+
+#ifdef PRINT_DEBUG_INFO_
+    cout << "\n(" << myRank << ")About to compute Ghost Vertices...";
+    fflush(stdout);
+#endif
+#ifdef DEBUG_HANG_
+    if (myRank == 0)
+        cout << "\n(" << myRank << ")About to compute Ghost Vertices...";
+    fflush(stdout);
+#endif
+
+    // Define Adjacency Lists for Ghost Vertices:
+    // cout<<"Building Ghost data structures ... \n\n";
+    vector<MilanLongInt> verGhostPtr, verGhostInd, tempCounter;
+    // Mate array for ghost vertices:
+    vector<MilanLongInt> GMate; // Proportional to the number of ghost vertices
+    MilanLongInt S;
+    MilanLongInt privateMyCard = 0;
+    vector<MilanLongInt> PCumulative, PMessageBundle, PSizeInfoMessages;
+    vector<MPI_Request> SRequest;  // Requests that are used for each send message
+    vector<MPI_Status> SStatus;    // Status of sent messages, used in MPI_Wait
+    MilanLongInt MessageIndex = 0; // Pointer for current message
+    MilanInt BufferSize;
+    MilanLongInt *Buffer;
+
+    vector<MilanLongInt> privateQLocalVtx, privateQGhostVtx, privateQMsgType;
+    vector<MilanInt> privateQOwner;
+    vector<MilanLongInt> U, privateU;
+
+    initialize(NLVer, NLEdge, StartIndex,
+               EndIndex, &numGhostEdges,
+               &numGhostVertices, &S,
+               verLocInd, verLocPtr,
+               Ghost2LocalMap, Counter,
+               verGhostPtr, verGhostInd,
+               tempCounter, GMate,
+               Message, QLocalVtx,
+               QGhostVtx, QMsgType, QOwner,
+               candidateMate, U,
+               privateU,
+               privateQLocalVtx,
+               privateQGhostVtx,
+               privateQMsgType,
+               privateQOwner);
+
+    finishTime = MPI_Wtime();
+    *ph0_time = finishTime - startTime; // Time taken for Phase-0: Initialization
+#ifdef DEBUG_HANG_
+    cout << myRank << " Finished initialization" << endl;
+    fflush(stdout);
+#endif
+   
+    startTime = MPI_Wtime();
+
+    /////////////////////////////////////////////////////////////////////////////////////////
+    //////////////////////////////////// INITIALIZATION /////////////////////////////////////
+    /////////////////////////////////////////////////////////////////////////////////////////
+    // Compute the Initial Matching Set:
+
+    /*
+     * OMP PARALLEL_COMPUTE_CANDIDATE_MATE_B has been splitted from
+     * PARALLEL_PROCESS_EXPOSED_VERTEX_B in order to better parallelize
+     * the two.
+     * PARALLEL_COMPUTE_CANDIDATE_MATE_B is now totally parallel.
+     */
+
+    PARALLEL_COMPUTE_CANDIDATE_MATE_B(NLVer,
+                                      verLocPtr,
+                                      verLocInd,
+                                      myRank,
+                                      edgeLocWeight,
+                                      candidateMate);
+
+#ifdef DEBUG_HANG_
+    cout << myRank << " Finished Exposed Vertex" << endl;
+    fflush(stdout);
+#if 0
+    cout << myRank << " candidateMate after parallelCompute " <<endl;
+    for (int i=0; i<NLVer; i++) {
+      cout << candidateMate[i] << " " ;
+    }
+    cout << endl;
+#endif
+#endif
+    /*
+     * PARALLEL_PROCESS_EXPOSED_VERTEX_B
+     * TODO: write comment
+     *
+     * TODO: Test when it's actually more efficient to execute this code
+     *       in parallel.
+     */
+    PARALLEL_PROCESS_EXPOSED_VERTEX_B(NLVer,
+                                      candidateMate,
+                                      verLocInd,
+                                      verLocPtr,
+                                      StartIndex,
+                                      EndIndex,
+                                      Mate,
+                                      GMate,
+                                      Ghost2LocalMap,
+                                      edgeLocWeight,
+                                      &myCard,
+                                      &msgInd,
+                                      &NumMessagesBundled,
+                                      &S,
+                                      verDistance,
+                                      PCounter,
+                                      Counter,
+                                      myRank,
+                                      numProcs,
+                                      U,
+                                      privateU,
+                                      QLocalVtx,
+                                      QGhostVtx,
+                                      QMsgType,
+                                      QOwner,
+                                      privateQLocalVtx,
+                                      privateQGhostVtx,
+                                      privateQMsgType,
+                                      privateQOwner);
+
+    tempCounter.clear(); // Do not need this any more
+
+#ifdef DEBUG_HANG_
+    cout << myRank << " Finished Exposed Vertex" << endl;
+    fflush(stdout);
+#if 0
+    cout << myRank << " Mate after Exposed Vertices " <<endl;
+    for (int i=0; i<NLVer; i++) {
+      cout << Mate[i] << " " ;
+    }
+    cout << endl;
+#endif
+#endif
+
+    ///////////////////////////////////////////////////////////////////////////////////
+    /////////////////////////// PROCESS MATCHED VERTICES //////////////////////////////
+    ///////////////////////////////////////////////////////////////////////////////////
+
+    // TODO what would be the optimal UCHUNK
+    vector<MilanLongInt> UChunkBeingProcessed;
+    UChunkBeingProcessed.reserve(UCHUNK);
+
+    processMatchedVertices(NLVer,
+                           UChunkBeingProcessed,
+                           U,
+                           privateU,
+                           StartIndex,
+                           EndIndex,
+                           &myCard,
+                           &msgInd,
+                           &NumMessagesBundled,
+                           &S,
+                           verLocPtr,
+                           verLocInd,
+                           verDistance,
+                           PCounter,
+                           Counter,
+                           myRank,
+                           numProcs,
+                           candidateMate,
+                           GMate,
+                           Mate,
+                           Ghost2LocalMap,
+                           edgeLocWeight,
+                           QLocalVtx,
+                           QGhostVtx,
+                           QMsgType,
+                           QOwner,
+                           privateQLocalVtx,
+                           privateQGhostVtx,
+                           privateQMsgType,
+                           privateQOwner);
+
+
+#ifdef DEBUG_HANG_
+    cout << myRank << " Finished Process Vertices" << endl;
+    fflush(stdout);
+#if 0
+    cout << myRank << " Mate after Matched Vertices " <<endl;
+    for (int i=0; i<NLVer; i++) {
+      cout << Mate[i] << " " ;
+    }
+    cout << endl;
+#endif
+#endif
+
+    /////////////////////////////////////////////////////////////////////////////////////////
+    ///////////////////////////// SEND BUNDLED MESSAGES /////////////////////////////////////
+    /////////////////////////////////////////////////////////////////////////////////////////
+
+    sendBundledMessages(&numGhostEdges,
+                        &BufferSize,
+                        Buffer,
+                        PCumulative,
+                        PMessageBundle,
+                        PSizeInfoMessages,
+                        PCounter,
+                        NumMessagesBundled,
+                        &msgActual,
+                        &MessageIndex,
+                        numProcs,
+                        myRank,
+                        comm,
+                        QLocalVtx,
+                        QGhostVtx,
+                        QMsgType,
+                        QOwner,
+                        SRequest,
+                        SStatus);
+
+    ///////////////////////// END OF SEND BUNDLED MESSAGES //////////////////////////////////
+
+    finishTime = MPI_Wtime();
+    *ph1_time = finishTime - startTime; // Time taken for Phase-1
+
+#ifdef DEBUG_HANG_
+    cout << myRank << " Finished sendBundles" << endl;
+    fflush(stdout);
+#endif
+ 
+    *ph1_card = myCard;                 // Cardinality at the end of Phase-1
+    startTime = MPI_Wtime();
+    /////////////////////////////////////////////////////////////////////////////////////////
+    //////////////////////////////////////// MAIN LOOP //////////////////////////////////////
+    /////////////////////////////////////////////////////////////////////////////////////////
+    // Main While Loop:
+#ifdef PRINT_DEBUG_INFO_
+    cout << "\n(" << myRank << "=========================************===============================" << endl;
+    fflush(stdout);
+    fflush(stdout);
+#endif
+#ifdef PRINT_DEBUG_INFO_
+    cout << "\n(" << myRank << ")Entering While(true) loop..";
+    fflush(stdout);
+#endif
+#ifdef PRINT_DEBUG_INFO_
+    cout << "\n(" << myRank << "=========================************===============================" << endl;
+    fflush(stdout);
+    fflush(stdout);
+#endif
+
+    while (true)  {
+#ifdef DEBUG_HANG_
+      //if (myRank == 0)
+      cout << "\n(" << myRank << ") Main loop" << endl;
+      fflush(stdout);
+#endif
+        ///////////////////////////////////////////////////////////////////////////////////
+        /////////////////////////// PROCESS MATCHED VERTICES //////////////////////////////
+        ///////////////////////////////////////////////////////////////////////////////////
+      
+      processMatchedVerticesAndSendMessages(NLVer,
+					    UChunkBeingProcessed,
+					    U,
+					    privateU,
+					    StartIndex,
+					    EndIndex,
+					    &myCard,
+					    &msgInd,
+					    &NumMessagesBundled,
+					    &S,
+					    verLocPtr,
+					    verLocInd,
+					    verDistance,
+					    PCounter,
+					    Counter,
+					    myRank,
+					    numProcs,
+					    candidateMate,
+					    GMate,
+					    Mate,
+					    Ghost2LocalMap,
+					    edgeLocWeight,
+					    QLocalVtx,
+					    QGhostVtx,
+					    QMsgType,
+					    QOwner,
+					    privateQLocalVtx,
+					    privateQGhostVtx,
+					    privateQMsgType,
+					    privateQOwner,
+					    comm,
+					    &msgActual,
+					    Message);
+      
+      ///////////////////////// END OF PROCESS MATCHED VERTICES /////////////////////////
+
+        //// BREAK IF NO MESSAGES EXPECTED /////////
+#ifdef DEBUG_HANG_
+#if 0
+      cout << myRank << " Mate after ProcessMatchedAndSend phase "<<S <<endl;
+      for (int i=0; i<NLVer; i++) {
+	cout << Mate[i] << " " ;
+      }
+      cout << endl;
+#endif
+#endif
+#ifdef PRINT_DEBUG_INFO_
+        cout << "\n(" << myRank << ")Deciding whether to break: S= " << S << endl;
+#endif
+
+        if (S == 0) {
+#ifdef DEBUG_HANG_
+	  cout << "\n(" << myRank << ") Breaking out" << endl;
+	  fflush(stdout);
+#endif
+	  break;
+        }
+        ///////////////////////////////////////////////////////////////////////////////////
+        /////////////////////////// PROCESS MESSAGES //////////////////////////////////////
+        ///////////////////////////////////////////////////////////////////////////////////
+
+        processMessages(NLVer,
+                        Mate,
+                        candidateMate,
+                        Ghost2LocalMap,
+                        GMate,
+                        Counter,
+                        StartIndex,
+                        EndIndex,
+                        &myCard,
+                        &msgInd,
+                        &msgActual,
+                        edgeLocWeight,
+                        verDistance,
+                        verLocPtr,
+                        k,
+                        verLocInd,
+                        numProcs,
+                        myRank,
+                        comm,
+                        Message,
+                        numGhostEdges,
+                        u,
+                        v,
+                        &S,
+                        U);
+
+        ///////////////////////// END OF PROCESS MESSAGES /////////////////////////////////
+#ifdef DEBUG_HANG_
+#if 0
+      cout << myRank << " Mate after ProcessMessages phase "<<S <<endl;
+      for (int i=0; i<NLVer; i++) {
+	cout << Mate[i] << " " ;
+      }
+      cout << endl;
+#endif
+#endif
+#ifdef PRINT_DEBUG_INFO_
+        cout << "\n(" << myRank << ")Finished Message processing phase: S= " << S;
+        fflush(stdout);
+        cout << "\n(" << myRank << ")** SENT     : ACTUAL= " << msgActual;
+        fflush(stdout);
+        cout << "\n(" << myRank << ")** SENT     : INDIVIDUAL= " << msgInd << endl;
+        fflush(stdout);
+#endif
+    } // End of while (true)
+
+    clean(NLVer,
+          myRank,
+          MessageIndex,
+          SRequest,
+          SStatus,
+          BufferSize,
+          Buffer,
+          msgActual,
+          msgActualSent,
+          msgInd,
+          msgIndSent,
+          NumMessagesBundled,
+          msgPercent);
+
+    finishTime = MPI_Wtime();
+    *ph2_time = finishTime - startTime; // Time taken for Phase-2
+    *ph2_card = myCard;                 // Cardinality at the end of Phase-2
+}
+// End of algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMate
+#endif
+
+#endif

amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90

@@ -97,6 +97,8 @@ subroutine  amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
   integer(psb_lpk_)   :: ntaggr
   integer(psb_ipk_)   :: debug_level, debug_unit
   logical             :: clean_zeros
+  integer(psb_ipk_), save :: idx_map_bld=-1, idx_map_tprol=-1
+  logical, parameter      :: do_timings=.false.
 
   name='amg_c_dec_aggregator_tprol'
   call psb_erractionsave(err_act)
@@ -108,6 +110,10 @@ subroutine  amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  if ((do_timings).and.(idx_map_bld==-1))       &
+       & idx_map_bld = psb_get_timer_idx("DEC_TPROL: map_bld")
+  if ((do_timings).and.(idx_map_tprol==-1))     &
+       & idx_map_tprol = psb_get_timer_idx("DEC_TPROL: map_tprol")
 
   call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
        &   amg_mult_ml_,is_legal_ml_cycle)
@@ -121,10 +127,14 @@ subroutine  amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
   ! The decoupled aggregator based on SOC measures ignores
   ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
   !
+  if (do_timings) call psb_tic(idx_map_bld)
   clean_zeros = ag%do_clean_zeros
   call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+  if (do_timings) call psb_toc(idx_map_bld)
+  if (do_timings) call psb_tic(idx_map_tprol)
 
   if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+  if (do_timings) call psb_toc(idx_map_tprol)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_c_ptap_bld.f90

@@ -76,7 +76,7 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
   integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
   logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
+  integer(psb_ipk_), save :: idx_spspmm=-1, idx_cpytrans1=-1, idx_cpytrans2=-1
 
   name='amg_ptap_bld'
   if(psb_get_errstatus().ne.0) return 
@@ -93,7 +93,11 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   ncol  = desc_a%get_local_cols()
 
   if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+       & idx_spspmm = psb_get_timer_idx("PTAP_BLD: par_spspmm")
+  if ((do_timings).and.(idx_cpytrans1==-1)) &
+       & idx_cpytrans1 = psb_get_timer_idx("PTAP_BLD: cpy&trans1")
+  if ((do_timings).and.(idx_cpytrans2==-1)) &
+       & idx_cpytrans2 = psb_get_timer_idx("PTAP_BLD: cpy&trans2")
 
   naggr   = nlaggr(me+1)
   ntaggr  = sum(nlaggr)
@@ -128,6 +132,7 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   ! Ok first product done.
 
   if (present(desc_ax)) then
+    if (do_timings) call psb_tic(idx_cpytrans1)
     block 
       call coo_prol%cp_to_coo(coo_restr,info)
       call coo_restr%set_ncols(desc_ac%get_local_cols())
@@ -137,7 +142,7 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
       call coo_restr%set_ncols(desc_ax%get_local_cols())
     end block
     call csr_restr%cp_from_coo(coo_restr,info)
-
+    if (do_timings) call psb_toc(idx_cpytrans1)
     if (info /= psb_success_) then 
       call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
       goto 9999
@@ -167,27 +172,28 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
 
     call coo_restr%transp()
     nzl = coo_restr%get_nzeros()
-    nrl = desc_ac%get_local_rows() 
-    i=0
+    nrl = desc_ac%get_local_rows()
+    call coo_restr%fix(info)
+    i=coo_restr%get_nzeros()
     !
     ! Only keep local rows
     !
-    do k=1, nzl
-      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
-        i = i+1
-        coo_restr%val(i) = coo_restr%val(k)
-        coo_restr%ia(i)  = coo_restr%ia(k)
-        coo_restr%ja(i)  = coo_restr%ja(k)
+    search: do k=i,1,-1
+      if (coo_restr%ia(k) <= nrl) then
+        call coo_restr%set_nzeros(k)
+        exit search
       end if
-    end do
-    call coo_restr%set_nzeros(i)
-    call coo_restr%fix(info) 
+    end do search
+
     nzl  = coo_restr%get_nzeros()
     call coo_restr%set_nrows(desc_ac%get_local_rows())
     call coo_restr%set_ncols(desc_a%get_local_cols())
     if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    if (do_timings) call psb_tic(idx_cpytrans2)
+        
     call csr_restr%cp_from_coo(coo_restr,info)
 
+    if (do_timings) call psb_toc(idx_cpytrans2)
     if (info /= psb_success_) then 
       call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
       goto 9999

amgprec/impl/aggregator/amg_c_soc1_map_bld.F90

@@ -72,7 +72,9 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   use psb_base_mod
   use amg_base_prec_type
   use amg_c_inner_mod
-
+#if defined(OPENMP)
+  use omp_lib
+#endif
   implicit none
 
   ! Arguments
@@ -85,7 +87,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_), intent(out)               :: info
 
   ! Local variables
-  integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),&
+  integer(psb_ipk_), allocatable :: neigh(:), irow(:), icol(:),&
        & ideg(:), idxs(:)
   integer(psb_lpk_), allocatable :: tmpaggr(:)
   complex(psb_spk_), allocatable  :: val(:), diag(:)
@@ -99,6 +101,9 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_)   :: nrow, ncol, n_ne
   integer(psb_lpk_)   :: nrglob
   character(len=20)   :: name, ch_err
+  integer(psb_ipk_), save :: idx_soc1_p1=-1, idx_soc1_p2=-1, idx_soc1_p3=-1
+  integer(psb_ipk_), save :: idx_soc1_p0=-1
+  logical, parameter      :: do_timings=.true.
 
   info=psb_success_
   name = 'amg_soc1_map_bld'
@@ -114,6 +119,14 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nrow   = desc_a%get_local_rows()
   ncol   = desc_a%get_local_cols()
   nrglob = desc_a%get_global_rows()
+  if ((do_timings).and.(idx_soc1_p0==-1))       &
+       & idx_soc1_p0 = psb_get_timer_idx("SOC1_MAP: phase0")
+  if ((do_timings).and.(idx_soc1_p1==-1))       &
+       & idx_soc1_p1 = psb_get_timer_idx("SOC1_MAP: phase1")
+  if ((do_timings).and.(idx_soc1_p2==-1))       &
+       & idx_soc1_p2 = psb_get_timer_idx("SOC1_MAP: phase2")
+  if ((do_timings).and.(idx_soc1_p3==-1))       &
+       & idx_soc1_p3 = psb_get_timer_idx("SOC1_MAP: phase3")
 
   nr = a%get_nrows()
   nc = a%get_ncols()
@@ -133,41 +146,204 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
     goto 9999
   end if
 
+  if (do_timings) call psb_tic(idx_soc1_p0)
   call a%cp_to(acsr)
+  if (do_timings) call psb_toc(idx_soc1_p0)
   if (clean_zeros) call acsr%clean_zeros(info)
   if (iorder == amg_aggr_ord_nat_) then 
+    !$omp parallel do private(i) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
-      idxs(i)   = i 
+      idxs(i)   = i
     end do
-  else 
+    !$omp end parallel do 
+  else
+    !$omp parallel do private(i) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       ideg(i)   = acsr%irp(i+1) - acsr%irp(i)
     end do
+    !$omp end parallel do 
     call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
   end if
-
+  if (do_timings) call psb_tic(idx_soc1_p1)
 
   !
   ! Phase one: Start with disjoint groups.
   ! 
   naggr = 0
-  icnt = 0
+#if defined(OPENMP)
+  block
+    integer(psb_ipk_), allocatable  :: bnds(:), locnaggr(:)
+    integer(psb_ipk_) :: myth,nths, kk
+    ! The parallelization makes use of a locaggr(:) array; each thread
+    ! keeps its own version of naggr, and when the loop ends, a prefix is applied
+    ! to locnaggr to determine:
+    ! 1. The total number of aggregaters NAGGR;
+    ! 2. How much should each thread shift its own aggregates
+    ! Part 2 requires to keep track of which thread defined each entry
+    ! of ilaggr(), so that each entry can be adjusted correctly: even
+    ! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
+    ! been set because it is strongly connected to an entry J belonging to a
+    ! different thread. 
+
+    !$omp parallel shared(bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
+    !$omp private(icol,val,myth,kk) 
+    block
+      integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz, nc, i,j,m, nz, ilg,  ip, rsz
+      integer(psb_lpk_) :: itmp
+      !$omp master
+      nths = omp_get_num_threads()
+      allocate(bnds(0:nths),locnaggr(0:nths+1))
+      locnaggr(:) = 0
+      bnds(0) = 1
+      !$omp end master      
+      !$omp barrier
+      myth = omp_get_thread_num()
+      rsz = nr/nths
+      if (myth < mod(nr,nths)) rsz = rsz + 1
+      bnds(myth+1) = rsz
+      !$omp barrier
+      !$omp master
+      do i=1,nths
+        bnds(i) = bnds(i) + bnds(i-1)
+      end do
+      info = 0
+      !$omp end master
+      !$omp barrier
+      
+      !$omp do schedule(static) private(disjoint) 
+      do kk=0, nths-1
+        step1: do ii=bnds(kk), bnds(kk+1)-1
+          i = idxs(ii)          
+          if (info /= 0) cycle step1
+          if ((i<1).or.(i>nr)) then
+            !$omp atomic write
+            info=psb_err_internal_error_
+            !$omp end atomic 
+            call psb_errpush(info,name)
+            cycle step1
+            !goto 9999
+          end if
+            
+          if (ilaggr(i) == -(nr+1)) then
+            nz         = (acsr%irp(i+1)-acsr%irp(i))
+            if ((nz<0).or.(nz>size(icol))) then
+              !$omp atomic write
+              info=psb_err_internal_error_
+              !$omp end atomic 
+              call psb_errpush(info,name)
+              cycle step1
+              !goto 9999
+            end if
+
+            icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
+            val(1:nz)  = acsr%val(acsr%irp(i):acsr%irp(i+1)-1) 
+
+            !
+            ! Build the set of all strongly coupled nodes 
+            !
+            ip = 0
+            do k=1, nz
+              j   = icol(k)
+              ! If any of the neighbours is already assigned,
+              ! we will not reset. 
+              if (j>nr) cycle step1
+              if (ilaggr(j) > 0) cycle step1
+              if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
+                ip = ip + 1
+                icol(ip) = icol(k)
+              end if
+            enddo
+            
+            !
+            ! If the whole strongly coupled neighborhood of I is
+            ! as yet unconnected, turn it into the next aggregate.
+            ! Same if ip==0 (in which case, neighborhood only
+            ! contains I even if it does not look like it from matrix)
+            ! The fact that DISJOINT is private and not under lock
+            ! generates a certain un-repeatability, in that between
+            ! computing DISJOINT and assigning, another thread might
+            ! alter the values of ILAGGR.
+            ! However, a certain unrepeatability is already present
+            ! because the sequence of aggregates is computed with a
+            ! different order than in serial mode.
+            ! In any case, even if the enteries of ILAGGR may be
+            ! overwritten, the important thing is that each entry is
+            ! consistent and they generate a correct aggregation map.
+            !
+            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
+              if (itmp < (bnds(kk)-1+locnaggr(kk))) then
+                !$omp atomic update
+                info = max(12345678,info)
+                !$omp end atomic
+                cycle step1
+              end if
+              !$omp atomic write
+              ilaggr(i) = itmp
+              !$omp end atomic
+              do k=1, ip
+                !$omp atomic write
+                ilaggr(icol(k)) = itmp
+                !$omp end atomic
+              end do
+            end if
+          end if
+        enddo step1
+      end do
+      !$omp end do
+
+      !$omp master
+      naggr = sum(locnaggr(0:nths-1))
+      do i=1,nths
+        locnaggr(i) = locnaggr(i) + locnaggr(i-1)
+      end do
+      do i=nths+1,1,-1
+        locnaggr(i) = locnaggr(i-1)
+      end do
+      locnaggr(0) = 0
+      !$omp end master 
+      !$omp barrier
+      !$omp  do schedule(static) 
+      do kk=0, nths-1
+        do ii=bnds(kk), bnds(kk+1)-1
+          if (ilaggr(ii) > 0) then 
+            kp = mod(ilaggr(ii),nths)
+            ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
+          end if
+        end do
+      end do
+      !$omp end do
+    end block
+    !$omp end parallel
+  end block
+  if (info /= 0) then
+    if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+#else
   step1: do ii=1, nr
+    if (info /= 0) cycle
     i = idxs(ii)
     if ((i<1).or.(i>nr)) then
       info=psb_err_internal_error_
       call psb_errpush(info,name)
-      goto 9999
+      cycle step1
+      !goto 9999
     end if
-    
+
     if (ilaggr(i) == -(nr+1)) then
       nz         = (acsr%irp(i+1)-acsr%irp(i))
       if ((nz<0).or.(nz>size(icol))) then
         info=psb_err_internal_error_
         call psb_errpush(info,name)
-        goto 9999
+        cycle step1
+        !goto 9999
       end if
 
       icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
@@ -176,7 +352,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       !
       ! Build the set of all strongly coupled nodes 
       !
-      ip = 0 
+      ip = 0
       do k=1, nz
         j   = icol(k)
         if ((1<=j).and.(j<=nr)) then 
@@ -194,8 +370,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       ! contains I even if it does not look like it from matrix)
       !
       disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
-      if (disjoint) then 
-        icnt      = icnt + 1 
+      if (disjoint) then       
         naggr     = naggr + 1
         do k=1, ip
           ilaggr(icol(k)) = naggr
@@ -204,16 +379,22 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     endif
   enddo step1
-  
+#endif
   if (debug_level >= psb_debug_outer_) then 
     write(debug_unit,*) me,' ',trim(name),&
-         & ' Check 1:',count(ilaggr == -(nr+1))
+         & ' Check   1:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
   end if
-
+  if (do_timings) call psb_toc(idx_soc1_p1)
+  if (do_timings) call psb_tic(idx_soc1_p2)
   !
   ! Phase two: join the neighbours
   !
+  !$omp workshare
   tmpaggr = ilaggr
+  !$omp end workshare
+  !$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,theta)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip,cpling)
   step2: do ii=1,nr
     i = idxs(ii)
 
@@ -244,8 +425,15 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     end if
   end do step2
+  !$omp end parallel do
+  if (do_timings) call psb_toc(idx_soc1_p2)
+  if (debug_level >= psb_debug_outer_) then 
+    write(debug_unit,*) me,' ',trim(name),&
+         & ' Check 1.5:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
+  end if
 
-
+  if (do_timings) call psb_tic(idx_soc1_p3)
   !
   ! Phase three: sweep over leftovers, if any 
   !
@@ -274,7 +462,6 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         end if
       enddo
       if (ip > 0) then
-        icnt      = icnt + 1 
         naggr     = naggr + 1
         ilaggr(i) = naggr
         do k=1, ip
@@ -292,7 +479,10 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   end do step3
 
   ! Any leftovers?
+  !$omp parallel do schedule(static) shared(ilaggr,info)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip)
   do i=1, nr
+    if (info /= 0) cycle
     if (ilaggr(i) < 0) then
       nz = (acsr%irp(i+1)-acsr%irp(i))
       if (nz == 1) then
@@ -303,15 +493,18 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         ! other processes. 
         ilaggr(i) = -(nrglob+nr)
       else
+        !$omp atomic write
         info=psb_err_internal_error_
+        !$omp end atomic
         call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
-        goto 9999
+        cycle 
       endif
     end if
   end do
-
+  !$omp end parallel do
+  if (info /= 0) goto 9999
+  if (do_timings) call psb_toc(idx_soc1_p3)
   if (naggr > ncol) then 
-    !write(0,*) name,'Error : naggr > ncol',naggr,ncol
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
     goto 9999
@@ -336,9 +529,13 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nlaggr(:) = 0
   nlaggr(me+1) = naggr
   call psb_sum(ctxt,nlaggr(1:np))
+  if (debug_level >= psb_debug_outer_) then 
+    write(debug_unit,*) me,' ',trim(name),&
+         & ' Check   2:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
+  end if
 
   call acsr%free()
-
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_c_soc2_map_bld.F90

@@ -68,9 +68,12 @@
 !
 subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
 
-  use psb_base_mod
+  use psb_base_mod 
   use amg_base_prec_type
   use amg_c_inner_mod
+#if defined(OPENMP)
+  use omp_lib
+#endif
 
   implicit none
 
@@ -99,6 +102,9 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_) :: np, me
   integer(psb_ipk_) :: nrow, ncol, n_ne
   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.
 
   info=psb_success_
   name = 'amg_soc2_map_bld'
@@ -114,6 +120,14 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nrow   = desc_a%get_local_rows()
   ncol   = desc_a%get_local_cols()
   nrglob = desc_a%get_global_rows()
+  if ((do_timings).and.(idx_soc2_p0==-1))       &
+       & idx_soc2_p0 = psb_get_timer_idx("SOC2_MAP: phase0")
+  if ((do_timings).and.(idx_soc2_p1==-1))       &
+       & idx_soc2_p1 = psb_get_timer_idx("SOC2_MAP: phase1")
+  if ((do_timings).and.(idx_soc2_p2==-1))       &
+       & idx_soc2_p2 = psb_get_timer_idx("SOC2_MAP: phase2")
+  if ((do_timings).and.(idx_soc2_p3==-1))       &
+       & idx_soc2_p3 = psb_get_timer_idx("SOC2_MAP: phase3")
 
   nr = a%get_nrows()
   nc = a%get_ncols()
@@ -125,6 +139,7 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
     goto 9999
   end if
 
+  if (do_timings) call psb_tic(idx_soc2_p0)
   diag = a%get_diag(info)
   if(info /= psb_success_) then
     info=psb_err_from_subroutine_
@@ -137,55 +152,217 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   ! 
   call a%cp_to(muij)
   if (clean_zeros) call muij%clean_zeros(info)
+  !$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
   do i=1, nr
     do k=muij%irp(i),muij%irp(i+1)-1
       j = muij%ja(k)
       if (j<= nr) muij%val(k) = abs(muij%val(k))/sqrt(abs(diag(i)*diag(j)))
     end do
   end do
-
+  !$omp end parallel do 
   !
   ! Compute the 1-neigbour; mark strong links with +1, weak links with -1
   !
   call s_neigh_coo%allocate(nr,nr,muij%get_nzeros())
-  ip = 0 
+  !$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
   do i=1, nr
     do k=muij%irp(i),muij%irp(i+1)-1
       j = muij%ja(k)
+      s_neigh_coo%ia(k)  = i
+      s_neigh_coo%ja(k)  = j
       if (j<=nr) then 
-        ip = ip + 1
-        s_neigh_coo%ia(ip)  = i
-        s_neigh_coo%ja(ip)  = j
         if (real(muij%val(k)) >= theta) then 
-          s_neigh_coo%val(ip) = sone
+          s_neigh_coo%val(k) = sone
         else
-          s_neigh_coo%val(ip) = -sone
+          s_neigh_coo%val(k) = -sone
         end if
+      else
+        s_neigh_coo%val(k) = -sone        
       end if
     end do
   end do
+  !$omp end parallel do
   !write(*,*) 'S_NEIGH: ',nr,ip
-  call s_neigh_coo%set_nzeros(ip)
+  call s_neigh_coo%set_nzeros(muij%get_nzeros())
   call s_neigh%mv_from_coo(s_neigh_coo,info)
 
-  if (iorder == amg_aggr_ord_nat_) then 
+  if (iorder == amg_aggr_ord_nat_) then
+    
+    !$omp parallel do private(i) shared(ilaggr,idxs) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       idxs(i)   = i 
     end do
+    !$omp end parallel do 
   else 
+    !$omp parallel do private(i) shared(ilaggr,idxs,muij)  schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       ideg(i)   = muij%irp(i+1) - muij%irp(i)
     end do
+    !$omp end parallel do
     call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
   end if
 
+  if (do_timings) call psb_toc(idx_soc2_p0)
+  if (do_timings) call psb_tic(idx_soc2_p1)
 
   !
   ! Phase one: Start with disjoint groups.
   ! 
   naggr = 0
+#if defined(OPENMP)
+  block
+    integer(psb_ipk_), allocatable  :: bnds(:), locnaggr(:)
+    integer(psb_ipk_) :: myth,nths, kk
+    ! The parallelization makes use of a locaggr(:) array; each thread
+    ! keeps its own version of naggr, and when the loop ends, a prefix is applied
+    ! to locnaggr to determine:
+    ! 1. The total number of aggregaters NAGGR;
+    ! 2. How much should each thread shift its own aggregates
+    ! Part 2 requires to keep track of which thread defined each entry
+    ! of ilaggr(), so that each entry can be adjusted correctly: even
+    ! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
+    ! been set because it is strongly connected to an entry J belonging to a
+    ! different thread. 
+
+    !$omp parallel shared(s_neigh,bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
+    !$omp private(icol,val,myth,kk) 
+    block
+      integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz,nc,i,j,m,nz,ilg,ip,rsz,ip1,nzcnt
+      integer(psb_lpk_) :: itmp
+      !$omp master
+      nths = omp_get_num_threads()
+      allocate(bnds(0:nths),locnaggr(0:nths+1))
+      locnaggr(:) = 0
+      bnds(0) = 1
+      !$omp end master      
+      !$omp barrier
+      myth = omp_get_thread_num()
+      rsz = nr/nths
+      if (myth < mod(nr,nths)) rsz = rsz + 1
+      bnds(myth+1) = rsz
+      !$omp barrier
+      !$omp master
+      do i=1,nths
+        bnds(i) = bnds(i) + bnds(i-1)
+      end do
+      info = 0
+      !$omp end master
+      !$omp barrier
+
+      !$omp do schedule(static) private(disjoint) 
+      do kk=0, nths-1
+        step1: do ii=bnds(kk), bnds(kk+1)-1
+          i = idxs(ii)
+          if (info /= 0) then
+            write(0,*) ' Step1:',kk,ii,i,info
+            cycle step1
+          end if
+          if ((i<1).or.(i>nr)) then
+            !$omp atomic write
+            info=psb_err_internal_error_
+            !$omp end atomic 
+            call psb_errpush(info,name)
+            cycle step1
+            !goto 9999
+          end if
+
+
+          if (ilaggr(i) == -(nr+1)) then 
+            !
+            ! Get the 1-neighbourhood of I 
+            !
+            ip1 = s_neigh%irp(i)
+            nz  = s_neigh%irp(i+1)-ip1
+            !
+            ! If the neighbourhood only contains I, skip it
+            !
+            if (nz ==0) then
+              ilaggr(i) = 0
+              cycle step1
+            end if
+            if ((nz==1).and.(s_neigh%ja(ip1)==i)) then
+              ilaggr(i) = 0
+              cycle step1
+            end if
+
+            nzcnt = count(real(s_neigh%val(ip1:ip1+nz-1)) > 0)
+            icol(1:nzcnt) = pack(s_neigh%ja(ip1:ip1+nz-1),(real(s_neigh%val(ip1:ip1+nz-1)) > 0))
+            disjoint = all(ilaggr(icol(1:nzcnt)) == -(nr+1)) 
+
+            !
+            ! If the whole strongly coupled neighborhood of I is
+            ! as yet unconnected, turn it into the next aggregate.
+            ! Same if ip==0 (in which case, neighborhood only
+            ! contains I even if it does not look like it from matrix)
+            ! The fact that DISJOINT is private and not under lock
+            ! generates a certain un-repeatability, in that between
+            ! computing DISJOINT and assigning, another thread might
+            ! alter the values of ILAGGR.
+            ! However, a certain unrepeatability is already present
+            ! because the sequence of aggregates is computed with a
+            ! different order than in serial mode.
+            ! In any case, even if the enteries of ILAGGR may be
+            ! overwritten, the important thing is that each entry is
+            ! consistent and they generate a correct aggregation map.
+            !
+            if (disjoint) then
+              locnaggr(kk)     = locnaggr(kk) + 1
+              itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
+              if (itmp < (bnds(kk)-1+locnaggr(kk))) then
+                !$omp atomic update
+                info = max(12345678,info)
+                !$omp end atomic
+                cycle step1
+              end if
+              !$omp atomic write
+              ilaggr(i) = itmp
+              !$omp end atomic
+              do k=1, nzcnt
+                !$omp atomic write
+                ilaggr(icol(k)) = itmp
+                !$omp end atomic
+              end do
+            end if
+          end if
+        enddo step1
+      end do
+      !$omp end do
+
+      !$omp master
+      naggr = sum(locnaggr(0:nths-1))
+      do i=1,nths
+        locnaggr(i) = locnaggr(i) + locnaggr(i-1)
+      end do
+      do i=nths+1,1,-1
+        locnaggr(i) = locnaggr(i-1)
+      end do
+      locnaggr(0) = 0
+      !write(0,*) 'LNAG ',locnaggr(nths+1)
+      !$omp end master 
+      !$omp barrier
+      !$omp  do schedule(static) 
+      do kk=0, nths-1
+        do ii=bnds(kk), bnds(kk+1)-1
+          if (ilaggr(ii) > 0) then 
+            kp = mod(ilaggr(ii),nths)
+            ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
+          end if
+        end do
+      end do
+      !$omp end do
+    end block
+    !$omp end parallel
+  end block
+  if (info /= 0) then
+    if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+#else
   icnt = 0
   step1: do ii=1, nr
     i = idxs(ii)
@@ -224,16 +401,21 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     endif
   enddo step1
-  
+#endif  
   if (debug_level >= psb_debug_outer_) then 
     write(debug_unit,*) me,' ',trim(name),&
          & ' Check 1:',count(ilaggr == -(nr+1))
   end if
-
+  if (do_timings) call psb_toc(idx_soc2_p1)
+  if (do_timings) call psb_tic(idx_soc2_p2)
   !
   ! Phase two: join the neighbours
   !
+  !$omp workshare
   tmpaggr = ilaggr
+  !$omp end workshare
+  !$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,muij,s_neigh)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip,cpling)
   step2: do ii=1,nr
     i = idxs(ii)
 
@@ -259,8 +441,9 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     end if
   end do step2
-
-
+  !$omp end parallel do
+  if (do_timings) call psb_toc(idx_soc2_p2)
+  if (do_timings) call psb_tic(idx_soc2_p3)
   !
   ! Phase three: sweep over leftovers, if any 
   !
@@ -294,6 +477,8 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   end do step3
 
   ! Any leftovers?
+  !$omp parallel do schedule(static) shared(ilaggr,s_neigh,info)& 
+  !$omp     private(ii,i,j,k)
   do i=1, nr
     if (ilaggr(i) <= 0) then
       nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
@@ -305,13 +490,17 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         ! other processes. 
         ilaggr(i) = -(nrglob+nr)
       else
+        !$omp atomic write
         info=psb_err_internal_error_
+        !$omp end atomic
         call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
-        goto 9999
+        cycle
       endif
     end if
   end do
-
+  !$omp end parallel do
+  if (info /= 0) goto 9999
+  if (do_timings) call psb_toc(idx_soc2_p3)  
   if (naggr > ncol) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')

amgprec/impl/aggregator/amg_caggrmat_smth_bld.f90

@@ -140,6 +140,9 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   real(psb_spk_)     :: anorm, omega, tmp, dg, theta
   logical, parameter :: debug_new=.false.
   character(len=80) :: filename
+  logical, parameter :: do_timings=.false.
+  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
 
   name='amg_aggrmat_smth_bld'
   info=psb_success_
@@ -153,6 +156,23 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   ctxt = desc_a%get_context()
 
   call psb_info(ctxt, me, np)
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("DEC_SMTH_BLD: par_spspmm")
+  if ((do_timings).and.(idx_phase1==-1)) &
+       & idx_phase1 = psb_get_timer_idx("DEC_SMTH_BLD: phase1    ")
+  if ((do_timings).and.(idx_phase2==-1)) &
+       & idx_phase2 = psb_get_timer_idx("DEC_SMTH_BLD: phase2    ")
+  if ((do_timings).and.(idx_phase3==-1)) &
+       & idx_phase3 = psb_get_timer_idx("DEC_SMTH_BLD: phase3    ")
+  if ((do_timings).and.(idx_gtrans==-1)) &
+       & idx_gtrans = psb_get_timer_idx("DEC_SMTH_BLD: gtrans    ")
+  if ((do_timings).and.(idx_refine==-1)) &
+       & idx_refine = psb_get_timer_idx("DEC_SMTH_BLD: refine    ")
+  if ((do_timings).and.(idx_cdasb==-1)) &
+       & idx_cdasb = psb_get_timer_idx("DEC_SMTH_BLD: cdasb     ")
+  if ((do_timings).and.(idx_ptap==-1)) &
+       & idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld  ")
+
 
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
@@ -171,6 +191,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   ! naggr: number of local aggregates
   ! nrow: local rows. 
   ! 
+  if (do_timings) call psb_tic(idx_phase1)
 
   ! Get the diagonal D
   adiag = a%get_diag(info)
@@ -196,7 +217,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     !
     ! Build the filtered matrix Af from A
     ! 
-
+    !$OMP parallel do private(i,j,tmp,jd) schedule(static)
     do i=1, nrow
       tmp = czero
       jd  = -1 
@@ -214,11 +235,13 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
         acsrf%val(jd)=acsrf%val(jd)-tmp
       end if
     enddo
+    !$OMP end parallel do 
     ! Take out zeroed terms 
     call acsrf%clean_zeros(info)
   end if
 
 
+  !$OMP parallel do private(i) schedule(static)
   do i=1,size(adiag)
     if (adiag(i) /= czero) then
       adiag(i) = cone / adiag(i)
@@ -226,7 +249,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
       adiag(i) = cone
     end if
   end do
-
+  !$OMP end parallel do 
   if (parms%aggr_omega_alg == amg_eig_est_) then 
 
     if (parms%aggr_eig == amg_max_norm_) then 
@@ -252,8 +275,9 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
     goto 9999
   end if
+  if (do_timings) call psb_toc(idx_phase1)
 
-  
+  if (do_timings) call psb_tic(idx_phase2)
   call acsrf%scal(adiag,info)
   if (info /= psb_success_) goto 9999
 
@@ -267,6 +291,8 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   call psb_cdasb(desc_ac,info)
   call psb_cd_reinit(desc_ac,info)
+  if (do_timings) call psb_toc(idx_phase2)
+  if (do_timings) call psb_tic(idx_phase3)
   !
   ! Build the smoothed prolongator using either A or Af
   !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
@@ -279,8 +305,8 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
     goto 9999
   end if
-
-
+  if (do_timings) call psb_toc(idx_phase3)
+  if (do_timings) call psb_tic(idx_ptap)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done SPSPMM 1'
@@ -292,7 +318,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   call op_prol%mv_from(coo_prol)
   call op_restr%mv_from(coo_restr)
-
+  if (do_timings) call psb_toc(idx_ptap)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done smooth_aggregate '

amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90

@@ -97,6 +97,8 @@ subroutine  amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
   integer(psb_lpk_)   :: ntaggr
   integer(psb_ipk_)   :: debug_level, debug_unit
   logical             :: clean_zeros
+  integer(psb_ipk_), save :: idx_map_bld=-1, idx_map_tprol=-1
+  logical, parameter      :: do_timings=.false.
 
   name='amg_d_dec_aggregator_tprol'
   call psb_erractionsave(err_act)
@@ -108,6 +110,10 @@ subroutine  amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  if ((do_timings).and.(idx_map_bld==-1))       &
+       & idx_map_bld = psb_get_timer_idx("DEC_TPROL: map_bld")
+  if ((do_timings).and.(idx_map_tprol==-1))     &
+       & idx_map_tprol = psb_get_timer_idx("DEC_TPROL: map_tprol")
 
   call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
        &   amg_mult_ml_,is_legal_ml_cycle)
@@ -121,10 +127,14 @@ subroutine  amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
   ! The decoupled aggregator based on SOC measures ignores
   ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
   !
+  if (do_timings) call psb_tic(idx_map_bld)
   clean_zeros = ag%do_clean_zeros
   call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+  if (do_timings) call psb_toc(idx_map_bld)
+  if (do_timings) call psb_tic(idx_map_tprol)
 
   if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+  if (do_timings) call psb_toc(idx_map_tprol)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_d_ptap_bld.f90

@@ -76,7 +76,7 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
   integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
   logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
+  integer(psb_ipk_), save :: idx_spspmm=-1, idx_cpytrans1=-1, idx_cpytrans2=-1
 
   name='amg_ptap_bld'
   if(psb_get_errstatus().ne.0) return 
@@ -93,7 +93,11 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   ncol  = desc_a%get_local_cols()
 
   if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+       & idx_spspmm = psb_get_timer_idx("PTAP_BLD: par_spspmm")
+  if ((do_timings).and.(idx_cpytrans1==-1)) &
+       & idx_cpytrans1 = psb_get_timer_idx("PTAP_BLD: cpy&trans1")
+  if ((do_timings).and.(idx_cpytrans2==-1)) &
+       & idx_cpytrans2 = psb_get_timer_idx("PTAP_BLD: cpy&trans2")
 
   naggr   = nlaggr(me+1)
   ntaggr  = sum(nlaggr)
@@ -128,6 +132,7 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   ! Ok first product done.
 
   if (present(desc_ax)) then
+    if (do_timings) call psb_tic(idx_cpytrans1)
     block 
       call coo_prol%cp_to_coo(coo_restr,info)
       call coo_restr%set_ncols(desc_ac%get_local_cols())
@@ -137,7 +142,7 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
       call coo_restr%set_ncols(desc_ax%get_local_cols())
     end block
     call csr_restr%cp_from_coo(coo_restr,info)
-
+    if (do_timings) call psb_toc(idx_cpytrans1)
     if (info /= psb_success_) then 
       call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
       goto 9999
@@ -167,27 +172,28 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
 
     call coo_restr%transp()
     nzl = coo_restr%get_nzeros()
-    nrl = desc_ac%get_local_rows() 
-    i=0
+    nrl = desc_ac%get_local_rows()
+    call coo_restr%fix(info)
+    i=coo_restr%get_nzeros()
     !
     ! Only keep local rows
     !
-    do k=1, nzl
-      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
-        i = i+1
-        coo_restr%val(i) = coo_restr%val(k)
-        coo_restr%ia(i)  = coo_restr%ia(k)
-        coo_restr%ja(i)  = coo_restr%ja(k)
+    search: do k=i,1,-1
+      if (coo_restr%ia(k) <= nrl) then
+        call coo_restr%set_nzeros(k)
+        exit search
       end if
-    end do
-    call coo_restr%set_nzeros(i)
-    call coo_restr%fix(info) 
+    end do search
+
     nzl  = coo_restr%get_nzeros()
     call coo_restr%set_nrows(desc_ac%get_local_rows())
     call coo_restr%set_ncols(desc_a%get_local_cols())
     if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    if (do_timings) call psb_tic(idx_cpytrans2)
+        
     call csr_restr%cp_from_coo(coo_restr,info)
 
+    if (do_timings) call psb_toc(idx_cpytrans2)
     if (info /= psb_success_) then 
       call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
       goto 9999

amgprec/impl/aggregator/amg_d_soc1_map_bld.F90

@@ -72,7 +72,9 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   use psb_base_mod
   use amg_base_prec_type
   use amg_d_inner_mod
-
+#if defined(OPENMP)
+  use omp_lib
+#endif
   implicit none
 
   ! Arguments
@@ -85,7 +87,7 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_), intent(out)               :: info
 
   ! Local variables
-  integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),&
+  integer(psb_ipk_), allocatable :: neigh(:), irow(:), icol(:),&
        & ideg(:), idxs(:)
   integer(psb_lpk_), allocatable :: tmpaggr(:)
   real(psb_dpk_), allocatable  :: val(:), diag(:)
@@ -99,6 +101,9 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_)   :: nrow, ncol, n_ne
   integer(psb_lpk_)   :: nrglob
   character(len=20)   :: name, ch_err
+  integer(psb_ipk_), save :: idx_soc1_p1=-1, idx_soc1_p2=-1, idx_soc1_p3=-1
+  integer(psb_ipk_), save :: idx_soc1_p0=-1
+  logical, parameter      :: do_timings=.true.
 
   info=psb_success_
   name = 'amg_soc1_map_bld'
@@ -114,6 +119,14 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nrow   = desc_a%get_local_rows()
   ncol   = desc_a%get_local_cols()
   nrglob = desc_a%get_global_rows()
+  if ((do_timings).and.(idx_soc1_p0==-1))       &
+       & idx_soc1_p0 = psb_get_timer_idx("SOC1_MAP: phase0")
+  if ((do_timings).and.(idx_soc1_p1==-1))       &
+       & idx_soc1_p1 = psb_get_timer_idx("SOC1_MAP: phase1")
+  if ((do_timings).and.(idx_soc1_p2==-1))       &
+       & idx_soc1_p2 = psb_get_timer_idx("SOC1_MAP: phase2")
+  if ((do_timings).and.(idx_soc1_p3==-1))       &
+       & idx_soc1_p3 = psb_get_timer_idx("SOC1_MAP: phase3")
 
   nr = a%get_nrows()
   nc = a%get_ncols()
@@ -133,41 +146,204 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
     goto 9999
   end if
 
+  if (do_timings) call psb_tic(idx_soc1_p0)
   call a%cp_to(acsr)
+  if (do_timings) call psb_toc(idx_soc1_p0)
   if (clean_zeros) call acsr%clean_zeros(info)
   if (iorder == amg_aggr_ord_nat_) then 
+    !$omp parallel do private(i) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
-      idxs(i)   = i 
+      idxs(i)   = i
     end do
-  else 
+    !$omp end parallel do 
+  else
+    !$omp parallel do private(i) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       ideg(i)   = acsr%irp(i+1) - acsr%irp(i)
     end do
+    !$omp end parallel do 
     call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
   end if
-
+  if (do_timings) call psb_tic(idx_soc1_p1)
 
   !
   ! Phase one: Start with disjoint groups.
   ! 
   naggr = 0
-  icnt = 0
+#if defined(OPENMP)
+  block
+    integer(psb_ipk_), allocatable  :: bnds(:), locnaggr(:)
+    integer(psb_ipk_) :: myth,nths, kk
+    ! The parallelization makes use of a locaggr(:) array; each thread
+    ! keeps its own version of naggr, and when the loop ends, a prefix is applied
+    ! to locnaggr to determine:
+    ! 1. The total number of aggregaters NAGGR;
+    ! 2. How much should each thread shift its own aggregates
+    ! Part 2 requires to keep track of which thread defined each entry
+    ! of ilaggr(), so that each entry can be adjusted correctly: even
+    ! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
+    ! been set because it is strongly connected to an entry J belonging to a
+    ! different thread. 
+
+    !$omp parallel shared(bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
+    !$omp private(icol,val,myth,kk) 
+    block
+      integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz, nc, i,j,m, nz, ilg,  ip, rsz
+      integer(psb_lpk_) :: itmp
+      !$omp master
+      nths = omp_get_num_threads()
+      allocate(bnds(0:nths),locnaggr(0:nths+1))
+      locnaggr(:) = 0
+      bnds(0) = 1
+      !$omp end master      
+      !$omp barrier
+      myth = omp_get_thread_num()
+      rsz = nr/nths
+      if (myth < mod(nr,nths)) rsz = rsz + 1
+      bnds(myth+1) = rsz
+      !$omp barrier
+      !$omp master
+      do i=1,nths
+        bnds(i) = bnds(i) + bnds(i-1)
+      end do
+      info = 0
+      !$omp end master
+      !$omp barrier
+      
+      !$omp do schedule(static) private(disjoint) 
+      do kk=0, nths-1
+        step1: do ii=bnds(kk), bnds(kk+1)-1
+          i = idxs(ii)          
+          if (info /= 0) cycle step1
+          if ((i<1).or.(i>nr)) then
+            !$omp atomic write
+            info=psb_err_internal_error_
+            !$omp end atomic 
+            call psb_errpush(info,name)
+            cycle step1
+            !goto 9999
+          end if
+            
+          if (ilaggr(i) == -(nr+1)) then
+            nz         = (acsr%irp(i+1)-acsr%irp(i))
+            if ((nz<0).or.(nz>size(icol))) then
+              !$omp atomic write
+              info=psb_err_internal_error_
+              !$omp end atomic 
+              call psb_errpush(info,name)
+              cycle step1
+              !goto 9999
+            end if
+
+            icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
+            val(1:nz)  = acsr%val(acsr%irp(i):acsr%irp(i+1)-1) 
+
+            !
+            ! Build the set of all strongly coupled nodes 
+            !
+            ip = 0
+            do k=1, nz
+              j   = icol(k)
+              ! If any of the neighbours is already assigned,
+              ! we will not reset. 
+              if (j>nr) cycle step1
+              if (ilaggr(j) > 0) cycle step1
+              if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
+                ip = ip + 1
+                icol(ip) = icol(k)
+              end if
+            enddo
+            
+            !
+            ! If the whole strongly coupled neighborhood of I is
+            ! as yet unconnected, turn it into the next aggregate.
+            ! Same if ip==0 (in which case, neighborhood only
+            ! contains I even if it does not look like it from matrix)
+            ! The fact that DISJOINT is private and not under lock
+            ! generates a certain un-repeatability, in that between
+            ! computing DISJOINT and assigning, another thread might
+            ! alter the values of ILAGGR.
+            ! However, a certain unrepeatability is already present
+            ! because the sequence of aggregates is computed with a
+            ! different order than in serial mode.
+            ! In any case, even if the enteries of ILAGGR may be
+            ! overwritten, the important thing is that each entry is
+            ! consistent and they generate a correct aggregation map.
+            !
+            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
+              if (itmp < (bnds(kk)-1+locnaggr(kk))) then
+                !$omp atomic update
+                info = max(12345678,info)
+                !$omp end atomic
+                cycle step1
+              end if
+              !$omp atomic write
+              ilaggr(i) = itmp
+              !$omp end atomic
+              do k=1, ip
+                !$omp atomic write
+                ilaggr(icol(k)) = itmp
+                !$omp end atomic
+              end do
+            end if
+          end if
+        enddo step1
+      end do
+      !$omp end do
+
+      !$omp master
+      naggr = sum(locnaggr(0:nths-1))
+      do i=1,nths
+        locnaggr(i) = locnaggr(i) + locnaggr(i-1)
+      end do
+      do i=nths+1,1,-1
+        locnaggr(i) = locnaggr(i-1)
+      end do
+      locnaggr(0) = 0
+      !$omp end master 
+      !$omp barrier
+      !$omp  do schedule(static) 
+      do kk=0, nths-1
+        do ii=bnds(kk), bnds(kk+1)-1
+          if (ilaggr(ii) > 0) then 
+            kp = mod(ilaggr(ii),nths)
+            ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
+          end if
+        end do
+      end do
+      !$omp end do
+    end block
+    !$omp end parallel
+  end block
+  if (info /= 0) then
+    if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+#else
   step1: do ii=1, nr
+    if (info /= 0) cycle
     i = idxs(ii)
     if ((i<1).or.(i>nr)) then
       info=psb_err_internal_error_
       call psb_errpush(info,name)
-      goto 9999
+      cycle step1
+      !goto 9999
     end if
-    
+
     if (ilaggr(i) == -(nr+1)) then
       nz         = (acsr%irp(i+1)-acsr%irp(i))
       if ((nz<0).or.(nz>size(icol))) then
         info=psb_err_internal_error_
         call psb_errpush(info,name)
-        goto 9999
+        cycle step1
+        !goto 9999
       end if
 
       icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
@@ -176,7 +352,7 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       !
       ! Build the set of all strongly coupled nodes 
       !
-      ip = 0 
+      ip = 0
       do k=1, nz
         j   = icol(k)
         if ((1<=j).and.(j<=nr)) then 
@@ -194,8 +370,7 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       ! contains I even if it does not look like it from matrix)
       !
       disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
-      if (disjoint) then 
-        icnt      = icnt + 1 
+      if (disjoint) then       
         naggr     = naggr + 1
         do k=1, ip
           ilaggr(icol(k)) = naggr
@@ -204,16 +379,22 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     endif
   enddo step1
-  
+#endif
   if (debug_level >= psb_debug_outer_) then 
     write(debug_unit,*) me,' ',trim(name),&
-         & ' Check 1:',count(ilaggr == -(nr+1))
+         & ' Check   1:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
   end if
-
+  if (do_timings) call psb_toc(idx_soc1_p1)
+  if (do_timings) call psb_tic(idx_soc1_p2)
   !
   ! Phase two: join the neighbours
   !
+  !$omp workshare
   tmpaggr = ilaggr
+  !$omp end workshare
+  !$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,theta)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip,cpling)
   step2: do ii=1,nr
     i = idxs(ii)
 
@@ -244,8 +425,15 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     end if
   end do step2
+  !$omp end parallel do
+  if (do_timings) call psb_toc(idx_soc1_p2)
+  if (debug_level >= psb_debug_outer_) then 
+    write(debug_unit,*) me,' ',trim(name),&
+         & ' Check 1.5:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
+  end if
 
-
+  if (do_timings) call psb_tic(idx_soc1_p3)
   !
   ! Phase three: sweep over leftovers, if any 
   !
@@ -274,7 +462,6 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         end if
       enddo
       if (ip > 0) then
-        icnt      = icnt + 1 
         naggr     = naggr + 1
         ilaggr(i) = naggr
         do k=1, ip
@@ -292,7 +479,10 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   end do step3
 
   ! Any leftovers?
+  !$omp parallel do schedule(static) shared(ilaggr,info)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip)
   do i=1, nr
+    if (info /= 0) cycle
     if (ilaggr(i) < 0) then
       nz = (acsr%irp(i+1)-acsr%irp(i))
       if (nz == 1) then
@@ -303,15 +493,18 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         ! other processes. 
         ilaggr(i) = -(nrglob+nr)
       else
+        !$omp atomic write
         info=psb_err_internal_error_
+        !$omp end atomic
         call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
-        goto 9999
+        cycle 
       endif
     end if
   end do
-
+  !$omp end parallel do
+  if (info /= 0) goto 9999
+  if (do_timings) call psb_toc(idx_soc1_p3)
   if (naggr > ncol) then 
-    !write(0,*) name,'Error : naggr > ncol',naggr,ncol
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
     goto 9999
@@ -336,9 +529,13 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nlaggr(:) = 0
   nlaggr(me+1) = naggr
   call psb_sum(ctxt,nlaggr(1:np))
+  if (debug_level >= psb_debug_outer_) then 
+    write(debug_unit,*) me,' ',trim(name),&
+         & ' Check   2:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
+  end if
 
   call acsr%free()
-
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_d_soc2_map_bld.F90

@@ -68,9 +68,12 @@
 !
 subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
 
-  use psb_base_mod
+  use psb_base_mod 
   use amg_base_prec_type
   use amg_d_inner_mod
+#if defined(OPENMP)
+  use omp_lib
+#endif
 
   implicit none
 
@@ -99,6 +102,9 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_) :: np, me
   integer(psb_ipk_) :: nrow, ncol, n_ne
   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.
 
   info=psb_success_
   name = 'amg_soc2_map_bld'
@@ -114,6 +120,14 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nrow   = desc_a%get_local_rows()
   ncol   = desc_a%get_local_cols()
   nrglob = desc_a%get_global_rows()
+  if ((do_timings).and.(idx_soc2_p0==-1))       &
+       & idx_soc2_p0 = psb_get_timer_idx("SOC2_MAP: phase0")
+  if ((do_timings).and.(idx_soc2_p1==-1))       &
+       & idx_soc2_p1 = psb_get_timer_idx("SOC2_MAP: phase1")
+  if ((do_timings).and.(idx_soc2_p2==-1))       &
+       & idx_soc2_p2 = psb_get_timer_idx("SOC2_MAP: phase2")
+  if ((do_timings).and.(idx_soc2_p3==-1))       &
+       & idx_soc2_p3 = psb_get_timer_idx("SOC2_MAP: phase3")
 
   nr = a%get_nrows()
   nc = a%get_ncols()
@@ -125,6 +139,7 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
     goto 9999
   end if
 
+  if (do_timings) call psb_tic(idx_soc2_p0)
   diag = a%get_diag(info)
   if(info /= psb_success_) then
     info=psb_err_from_subroutine_
@@ -137,55 +152,217 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   ! 
   call a%cp_to(muij)
   if (clean_zeros) call muij%clean_zeros(info)
+  !$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
   do i=1, nr
     do k=muij%irp(i),muij%irp(i+1)-1
       j = muij%ja(k)
       if (j<= nr) muij%val(k) = abs(muij%val(k))/sqrt(abs(diag(i)*diag(j)))
     end do
   end do
-
+  !$omp end parallel do 
   !
   ! Compute the 1-neigbour; mark strong links with +1, weak links with -1
   !
   call s_neigh_coo%allocate(nr,nr,muij%get_nzeros())
-  ip = 0 
+  !$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
   do i=1, nr
     do k=muij%irp(i),muij%irp(i+1)-1
       j = muij%ja(k)
+      s_neigh_coo%ia(k)  = i
+      s_neigh_coo%ja(k)  = j
       if (j<=nr) then 
-        ip = ip + 1
-        s_neigh_coo%ia(ip)  = i
-        s_neigh_coo%ja(ip)  = j
         if (real(muij%val(k)) >= theta) then 
-          s_neigh_coo%val(ip) = done
+          s_neigh_coo%val(k) = done
         else
-          s_neigh_coo%val(ip) = -done
+          s_neigh_coo%val(k) = -done
         end if
+      else
+        s_neigh_coo%val(k) = -done        
       end if
     end do
   end do
+  !$omp end parallel do
   !write(*,*) 'S_NEIGH: ',nr,ip
-  call s_neigh_coo%set_nzeros(ip)
+  call s_neigh_coo%set_nzeros(muij%get_nzeros())
   call s_neigh%mv_from_coo(s_neigh_coo,info)
 
-  if (iorder == amg_aggr_ord_nat_) then 
+  if (iorder == amg_aggr_ord_nat_) then
+    
+    !$omp parallel do private(i) shared(ilaggr,idxs) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       idxs(i)   = i 
     end do
+    !$omp end parallel do 
   else 
+    !$omp parallel do private(i) shared(ilaggr,idxs,muij)  schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       ideg(i)   = muij%irp(i+1) - muij%irp(i)
     end do
+    !$omp end parallel do
     call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
   end if
 
+  if (do_timings) call psb_toc(idx_soc2_p0)
+  if (do_timings) call psb_tic(idx_soc2_p1)
 
   !
   ! Phase one: Start with disjoint groups.
   ! 
   naggr = 0
+#if defined(OPENMP)
+  block
+    integer(psb_ipk_), allocatable  :: bnds(:), locnaggr(:)
+    integer(psb_ipk_) :: myth,nths, kk
+    ! The parallelization makes use of a locaggr(:) array; each thread
+    ! keeps its own version of naggr, and when the loop ends, a prefix is applied
+    ! to locnaggr to determine:
+    ! 1. The total number of aggregaters NAGGR;
+    ! 2. How much should each thread shift its own aggregates
+    ! Part 2 requires to keep track of which thread defined each entry
+    ! of ilaggr(), so that each entry can be adjusted correctly: even
+    ! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
+    ! been set because it is strongly connected to an entry J belonging to a
+    ! different thread. 
+
+    !$omp parallel shared(s_neigh,bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
+    !$omp private(icol,val,myth,kk) 
+    block
+      integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz,nc,i,j,m,nz,ilg,ip,rsz,ip1,nzcnt
+      integer(psb_lpk_) :: itmp
+      !$omp master
+      nths = omp_get_num_threads()
+      allocate(bnds(0:nths),locnaggr(0:nths+1))
+      locnaggr(:) = 0
+      bnds(0) = 1
+      !$omp end master      
+      !$omp barrier
+      myth = omp_get_thread_num()
+      rsz = nr/nths
+      if (myth < mod(nr,nths)) rsz = rsz + 1
+      bnds(myth+1) = rsz
+      !$omp barrier
+      !$omp master
+      do i=1,nths
+        bnds(i) = bnds(i) + bnds(i-1)
+      end do
+      info = 0
+      !$omp end master
+      !$omp barrier
+
+      !$omp do schedule(static) private(disjoint) 
+      do kk=0, nths-1
+        step1: do ii=bnds(kk), bnds(kk+1)-1
+          i = idxs(ii)
+          if (info /= 0) then
+            write(0,*) ' Step1:',kk,ii,i,info
+            cycle step1
+          end if
+          if ((i<1).or.(i>nr)) then
+            !$omp atomic write
+            info=psb_err_internal_error_
+            !$omp end atomic 
+            call psb_errpush(info,name)
+            cycle step1
+            !goto 9999
+          end if
+
+
+          if (ilaggr(i) == -(nr+1)) then 
+            !
+            ! Get the 1-neighbourhood of I 
+            !
+            ip1 = s_neigh%irp(i)
+            nz  = s_neigh%irp(i+1)-ip1
+            !
+            ! If the neighbourhood only contains I, skip it
+            !
+            if (nz ==0) then
+              ilaggr(i) = 0
+              cycle step1
+            end if
+            if ((nz==1).and.(s_neigh%ja(ip1)==i)) then
+              ilaggr(i) = 0
+              cycle step1
+            end if
+
+            nzcnt = count(real(s_neigh%val(ip1:ip1+nz-1)) > 0)
+            icol(1:nzcnt) = pack(s_neigh%ja(ip1:ip1+nz-1),(real(s_neigh%val(ip1:ip1+nz-1)) > 0))
+            disjoint = all(ilaggr(icol(1:nzcnt)) == -(nr+1)) 
+
+            !
+            ! If the whole strongly coupled neighborhood of I is
+            ! as yet unconnected, turn it into the next aggregate.
+            ! Same if ip==0 (in which case, neighborhood only
+            ! contains I even if it does not look like it from matrix)
+            ! The fact that DISJOINT is private and not under lock
+            ! generates a certain un-repeatability, in that between
+            ! computing DISJOINT and assigning, another thread might
+            ! alter the values of ILAGGR.
+            ! However, a certain unrepeatability is already present
+            ! because the sequence of aggregates is computed with a
+            ! different order than in serial mode.
+            ! In any case, even if the enteries of ILAGGR may be
+            ! overwritten, the important thing is that each entry is
+            ! consistent and they generate a correct aggregation map.
+            !
+            if (disjoint) then
+              locnaggr(kk)     = locnaggr(kk) + 1
+              itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
+              if (itmp < (bnds(kk)-1+locnaggr(kk))) then
+                !$omp atomic update
+                info = max(12345678,info)
+                !$omp end atomic
+                cycle step1
+              end if
+              !$omp atomic write
+              ilaggr(i) = itmp
+              !$omp end atomic
+              do k=1, nzcnt
+                !$omp atomic write
+                ilaggr(icol(k)) = itmp
+                !$omp end atomic
+              end do
+            end if
+          end if
+        enddo step1
+      end do
+      !$omp end do
+
+      !$omp master
+      naggr = sum(locnaggr(0:nths-1))
+      do i=1,nths
+        locnaggr(i) = locnaggr(i) + locnaggr(i-1)
+      end do
+      do i=nths+1,1,-1
+        locnaggr(i) = locnaggr(i-1)
+      end do
+      locnaggr(0) = 0
+      !write(0,*) 'LNAG ',locnaggr(nths+1)
+      !$omp end master 
+      !$omp barrier
+      !$omp  do schedule(static) 
+      do kk=0, nths-1
+        do ii=bnds(kk), bnds(kk+1)-1
+          if (ilaggr(ii) > 0) then 
+            kp = mod(ilaggr(ii),nths)
+            ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
+          end if
+        end do
+      end do
+      !$omp end do
+    end block
+    !$omp end parallel
+  end block
+  if (info /= 0) then
+    if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+#else
   icnt = 0
   step1: do ii=1, nr
     i = idxs(ii)
@@ -224,16 +401,21 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     endif
   enddo step1
-  
+#endif  
   if (debug_level >= psb_debug_outer_) then 
     write(debug_unit,*) me,' ',trim(name),&
          & ' Check 1:',count(ilaggr == -(nr+1))
   end if
-
+  if (do_timings) call psb_toc(idx_soc2_p1)
+  if (do_timings) call psb_tic(idx_soc2_p2)
   !
   ! Phase two: join the neighbours
   !
+  !$omp workshare
   tmpaggr = ilaggr
+  !$omp end workshare
+  !$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,muij,s_neigh)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip,cpling)
   step2: do ii=1,nr
     i = idxs(ii)
 
@@ -259,8 +441,9 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     end if
   end do step2
-
-
+  !$omp end parallel do
+  if (do_timings) call psb_toc(idx_soc2_p2)
+  if (do_timings) call psb_tic(idx_soc2_p3)
   !
   ! Phase three: sweep over leftovers, if any 
   !
@@ -294,6 +477,8 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   end do step3
 
   ! Any leftovers?
+  !$omp parallel do schedule(static) shared(ilaggr,s_neigh,info)& 
+  !$omp     private(ii,i,j,k)
   do i=1, nr
     if (ilaggr(i) <= 0) then
       nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
@@ -305,13 +490,17 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         ! other processes. 
         ilaggr(i) = -(nrglob+nr)
       else
+        !$omp atomic write
         info=psb_err_internal_error_
+        !$omp end atomic
         call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
-        goto 9999
+        cycle
       endif
     end if
   end do
-
+  !$omp end parallel do
+  if (info /= 0) goto 9999
+  if (do_timings) call psb_toc(idx_soc2_p3)  
   if (naggr > ncol) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')

amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90

@@ -140,6 +140,9 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   real(psb_dpk_)     :: anorm, omega, tmp, dg, theta
   logical, parameter :: debug_new=.false.
   character(len=80) :: filename
+  logical, parameter :: do_timings=.false.
+  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
 
   name='amg_aggrmat_smth_bld'
   info=psb_success_
@@ -153,6 +156,23 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   ctxt = desc_a%get_context()
 
   call psb_info(ctxt, me, np)
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("DEC_SMTH_BLD: par_spspmm")
+  if ((do_timings).and.(idx_phase1==-1)) &
+       & idx_phase1 = psb_get_timer_idx("DEC_SMTH_BLD: phase1    ")
+  if ((do_timings).and.(idx_phase2==-1)) &
+       & idx_phase2 = psb_get_timer_idx("DEC_SMTH_BLD: phase2    ")
+  if ((do_timings).and.(idx_phase3==-1)) &
+       & idx_phase3 = psb_get_timer_idx("DEC_SMTH_BLD: phase3    ")
+  if ((do_timings).and.(idx_gtrans==-1)) &
+       & idx_gtrans = psb_get_timer_idx("DEC_SMTH_BLD: gtrans    ")
+  if ((do_timings).and.(idx_refine==-1)) &
+       & idx_refine = psb_get_timer_idx("DEC_SMTH_BLD: refine    ")
+  if ((do_timings).and.(idx_cdasb==-1)) &
+       & idx_cdasb = psb_get_timer_idx("DEC_SMTH_BLD: cdasb     ")
+  if ((do_timings).and.(idx_ptap==-1)) &
+       & idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld  ")
+
 
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
@@ -171,6 +191,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   ! naggr: number of local aggregates
   ! nrow: local rows. 
   ! 
+  if (do_timings) call psb_tic(idx_phase1)
 
   ! Get the diagonal D
   adiag = a%get_diag(info)
@@ -196,7 +217,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     !
     ! Build the filtered matrix Af from A
     ! 
-
+    !$OMP parallel do private(i,j,tmp,jd) schedule(static)
     do i=1, nrow
       tmp = dzero
       jd  = -1 
@@ -214,11 +235,13 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
         acsrf%val(jd)=acsrf%val(jd)-tmp
       end if
     enddo
+    !$OMP end parallel do 
     ! Take out zeroed terms 
     call acsrf%clean_zeros(info)
   end if
 
 
+  !$OMP parallel do private(i) schedule(static)
   do i=1,size(adiag)
     if (adiag(i) /= dzero) then
       adiag(i) = done / adiag(i)
@@ -226,7 +249,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
       adiag(i) = done
     end if
   end do
-
+  !$OMP end parallel do 
   if (parms%aggr_omega_alg == amg_eig_est_) then 
 
     if (parms%aggr_eig == amg_max_norm_) then 
@@ -252,8 +275,9 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
     goto 9999
   end if
+  if (do_timings) call psb_toc(idx_phase1)
 
-  
+  if (do_timings) call psb_tic(idx_phase2)
   call acsrf%scal(adiag,info)
   if (info /= psb_success_) goto 9999
 
@@ -267,6 +291,8 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   call psb_cdasb(desc_ac,info)
   call psb_cd_reinit(desc_ac,info)
+  if (do_timings) call psb_toc(idx_phase2)
+  if (do_timings) call psb_tic(idx_phase3)
   !
   ! Build the smoothed prolongator using either A or Af
   !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
@@ -279,8 +305,8 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
     goto 9999
   end if
-
-
+  if (do_timings) call psb_toc(idx_phase3)
+  if (do_timings) call psb_tic(idx_ptap)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done SPSPMM 1'
@@ -292,7 +318,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   call op_prol%mv_from(coo_prol)
   call op_restr%mv_from(coo_restr)
-
+  if (do_timings) call psb_toc(idx_ptap)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done smooth_aggregate '

amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90

@@ -97,6 +97,8 @@ subroutine  amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
   integer(psb_lpk_)   :: ntaggr
   integer(psb_ipk_)   :: debug_level, debug_unit
   logical             :: clean_zeros
+  integer(psb_ipk_), save :: idx_map_bld=-1, idx_map_tprol=-1
+  logical, parameter      :: do_timings=.false.
 
   name='amg_s_dec_aggregator_tprol'
   call psb_erractionsave(err_act)
@@ -108,6 +110,10 @@ subroutine  amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  if ((do_timings).and.(idx_map_bld==-1))       &
+       & idx_map_bld = psb_get_timer_idx("DEC_TPROL: map_bld")
+  if ((do_timings).and.(idx_map_tprol==-1))     &
+       & idx_map_tprol = psb_get_timer_idx("DEC_TPROL: map_tprol")
 
   call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
        &   amg_mult_ml_,is_legal_ml_cycle)
@@ -121,10 +127,14 @@ subroutine  amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
   ! The decoupled aggregator based on SOC measures ignores
   ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
   !
+  if (do_timings) call psb_tic(idx_map_bld)
   clean_zeros = ag%do_clean_zeros
   call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+  if (do_timings) call psb_toc(idx_map_bld)
+  if (do_timings) call psb_tic(idx_map_tprol)
 
   if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+  if (do_timings) call psb_toc(idx_map_tprol)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_s_ptap_bld.f90

@@ -76,7 +76,7 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
   integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
   logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
+  integer(psb_ipk_), save :: idx_spspmm=-1, idx_cpytrans1=-1, idx_cpytrans2=-1
 
   name='amg_ptap_bld'
   if(psb_get_errstatus().ne.0) return 
@@ -93,7 +93,11 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   ncol  = desc_a%get_local_cols()
 
   if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+       & idx_spspmm = psb_get_timer_idx("PTAP_BLD: par_spspmm")
+  if ((do_timings).and.(idx_cpytrans1==-1)) &
+       & idx_cpytrans1 = psb_get_timer_idx("PTAP_BLD: cpy&trans1")
+  if ((do_timings).and.(idx_cpytrans2==-1)) &
+       & idx_cpytrans2 = psb_get_timer_idx("PTAP_BLD: cpy&trans2")
 
   naggr   = nlaggr(me+1)
   ntaggr  = sum(nlaggr)
@@ -128,6 +132,7 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   ! Ok first product done.
 
   if (present(desc_ax)) then
+    if (do_timings) call psb_tic(idx_cpytrans1)
     block 
       call coo_prol%cp_to_coo(coo_restr,info)
       call coo_restr%set_ncols(desc_ac%get_local_cols())
@@ -137,7 +142,7 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
       call coo_restr%set_ncols(desc_ax%get_local_cols())
     end block
     call csr_restr%cp_from_coo(coo_restr,info)
-
+    if (do_timings) call psb_toc(idx_cpytrans1)
     if (info /= psb_success_) then 
       call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
       goto 9999
@@ -167,27 +172,28 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
 
     call coo_restr%transp()
     nzl = coo_restr%get_nzeros()
-    nrl = desc_ac%get_local_rows() 
-    i=0
+    nrl = desc_ac%get_local_rows()
+    call coo_restr%fix(info)
+    i=coo_restr%get_nzeros()
     !
     ! Only keep local rows
     !
-    do k=1, nzl
-      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
-        i = i+1
-        coo_restr%val(i) = coo_restr%val(k)
-        coo_restr%ia(i)  = coo_restr%ia(k)
-        coo_restr%ja(i)  = coo_restr%ja(k)
+    search: do k=i,1,-1
+      if (coo_restr%ia(k) <= nrl) then
+        call coo_restr%set_nzeros(k)
+        exit search
       end if
-    end do
-    call coo_restr%set_nzeros(i)
-    call coo_restr%fix(info) 
+    end do search
+
     nzl  = coo_restr%get_nzeros()
     call coo_restr%set_nrows(desc_ac%get_local_rows())
     call coo_restr%set_ncols(desc_a%get_local_cols())
     if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    if (do_timings) call psb_tic(idx_cpytrans2)
+        
     call csr_restr%cp_from_coo(coo_restr,info)
 
+    if (do_timings) call psb_toc(idx_cpytrans2)
     if (info /= psb_success_) then 
       call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
       goto 9999

amgprec/impl/aggregator/amg_s_soc1_map_bld.F90

@@ -72,7 +72,9 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   use psb_base_mod
   use amg_base_prec_type
   use amg_s_inner_mod
-
+#if defined(OPENMP)
+  use omp_lib
+#endif
   implicit none
 
   ! Arguments
@@ -85,7 +87,7 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_), intent(out)               :: info
 
   ! Local variables
-  integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),&
+  integer(psb_ipk_), allocatable :: neigh(:), irow(:), icol(:),&
        & ideg(:), idxs(:)
   integer(psb_lpk_), allocatable :: tmpaggr(:)
   real(psb_spk_), allocatable  :: val(:), diag(:)
@@ -99,6 +101,9 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_)   :: nrow, ncol, n_ne
   integer(psb_lpk_)   :: nrglob
   character(len=20)   :: name, ch_err
+  integer(psb_ipk_), save :: idx_soc1_p1=-1, idx_soc1_p2=-1, idx_soc1_p3=-1
+  integer(psb_ipk_), save :: idx_soc1_p0=-1
+  logical, parameter      :: do_timings=.true.
 
   info=psb_success_
   name = 'amg_soc1_map_bld'
@@ -114,6 +119,14 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nrow   = desc_a%get_local_rows()
   ncol   = desc_a%get_local_cols()
   nrglob = desc_a%get_global_rows()
+  if ((do_timings).and.(idx_soc1_p0==-1))       &
+       & idx_soc1_p0 = psb_get_timer_idx("SOC1_MAP: phase0")
+  if ((do_timings).and.(idx_soc1_p1==-1))       &
+       & idx_soc1_p1 = psb_get_timer_idx("SOC1_MAP: phase1")
+  if ((do_timings).and.(idx_soc1_p2==-1))       &
+       & idx_soc1_p2 = psb_get_timer_idx("SOC1_MAP: phase2")
+  if ((do_timings).and.(idx_soc1_p3==-1))       &
+       & idx_soc1_p3 = psb_get_timer_idx("SOC1_MAP: phase3")
 
   nr = a%get_nrows()
   nc = a%get_ncols()
@@ -133,41 +146,204 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
     goto 9999
   end if
 
+  if (do_timings) call psb_tic(idx_soc1_p0)
   call a%cp_to(acsr)
+  if (do_timings) call psb_toc(idx_soc1_p0)
   if (clean_zeros) call acsr%clean_zeros(info)
   if (iorder == amg_aggr_ord_nat_) then 
+    !$omp parallel do private(i) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
-      idxs(i)   = i 
+      idxs(i)   = i
     end do
-  else 
+    !$omp end parallel do 
+  else
+    !$omp parallel do private(i) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       ideg(i)   = acsr%irp(i+1) - acsr%irp(i)
     end do
+    !$omp end parallel do 
     call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
   end if
-
+  if (do_timings) call psb_tic(idx_soc1_p1)
 
   !
   ! Phase one: Start with disjoint groups.
   ! 
   naggr = 0
-  icnt = 0
+#if defined(OPENMP)
+  block
+    integer(psb_ipk_), allocatable  :: bnds(:), locnaggr(:)
+    integer(psb_ipk_) :: myth,nths, kk
+    ! The parallelization makes use of a locaggr(:) array; each thread
+    ! keeps its own version of naggr, and when the loop ends, a prefix is applied
+    ! to locnaggr to determine:
+    ! 1. The total number of aggregaters NAGGR;
+    ! 2. How much should each thread shift its own aggregates
+    ! Part 2 requires to keep track of which thread defined each entry
+    ! of ilaggr(), so that each entry can be adjusted correctly: even
+    ! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
+    ! been set because it is strongly connected to an entry J belonging to a
+    ! different thread. 
+
+    !$omp parallel shared(bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
+    !$omp private(icol,val,myth,kk) 
+    block
+      integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz, nc, i,j,m, nz, ilg,  ip, rsz
+      integer(psb_lpk_) :: itmp
+      !$omp master
+      nths = omp_get_num_threads()
+      allocate(bnds(0:nths),locnaggr(0:nths+1))
+      locnaggr(:) = 0
+      bnds(0) = 1
+      !$omp end master      
+      !$omp barrier
+      myth = omp_get_thread_num()
+      rsz = nr/nths
+      if (myth < mod(nr,nths)) rsz = rsz + 1
+      bnds(myth+1) = rsz
+      !$omp barrier
+      !$omp master
+      do i=1,nths
+        bnds(i) = bnds(i) + bnds(i-1)
+      end do
+      info = 0
+      !$omp end master
+      !$omp barrier
+      
+      !$omp do schedule(static) private(disjoint) 
+      do kk=0, nths-1
+        step1: do ii=bnds(kk), bnds(kk+1)-1
+          i = idxs(ii)          
+          if (info /= 0) cycle step1
+          if ((i<1).or.(i>nr)) then
+            !$omp atomic write
+            info=psb_err_internal_error_
+            !$omp end atomic 
+            call psb_errpush(info,name)
+            cycle step1
+            !goto 9999
+          end if
+            
+          if (ilaggr(i) == -(nr+1)) then
+            nz         = (acsr%irp(i+1)-acsr%irp(i))
+            if ((nz<0).or.(nz>size(icol))) then
+              !$omp atomic write
+              info=psb_err_internal_error_
+              !$omp end atomic 
+              call psb_errpush(info,name)
+              cycle step1
+              !goto 9999
+            end if
+
+            icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
+            val(1:nz)  = acsr%val(acsr%irp(i):acsr%irp(i+1)-1) 
+
+            !
+            ! Build the set of all strongly coupled nodes 
+            !
+            ip = 0
+            do k=1, nz
+              j   = icol(k)
+              ! If any of the neighbours is already assigned,
+              ! we will not reset. 
+              if (j>nr) cycle step1
+              if (ilaggr(j) > 0) cycle step1
+              if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
+                ip = ip + 1
+                icol(ip) = icol(k)
+              end if
+            enddo
+            
+            !
+            ! If the whole strongly coupled neighborhood of I is
+            ! as yet unconnected, turn it into the next aggregate.
+            ! Same if ip==0 (in which case, neighborhood only
+            ! contains I even if it does not look like it from matrix)
+            ! The fact that DISJOINT is private and not under lock
+            ! generates a certain un-repeatability, in that between
+            ! computing DISJOINT and assigning, another thread might
+            ! alter the values of ILAGGR.
+            ! However, a certain unrepeatability is already present
+            ! because the sequence of aggregates is computed with a
+            ! different order than in serial mode.
+            ! In any case, even if the enteries of ILAGGR may be
+            ! overwritten, the important thing is that each entry is
+            ! consistent and they generate a correct aggregation map.
+            !
+            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
+              if (itmp < (bnds(kk)-1+locnaggr(kk))) then
+                !$omp atomic update
+                info = max(12345678,info)
+                !$omp end atomic
+                cycle step1
+              end if
+              !$omp atomic write
+              ilaggr(i) = itmp
+              !$omp end atomic
+              do k=1, ip
+                !$omp atomic write
+                ilaggr(icol(k)) = itmp
+                !$omp end atomic
+              end do
+            end if
+          end if
+        enddo step1
+      end do
+      !$omp end do
+
+      !$omp master
+      naggr = sum(locnaggr(0:nths-1))
+      do i=1,nths
+        locnaggr(i) = locnaggr(i) + locnaggr(i-1)
+      end do
+      do i=nths+1,1,-1
+        locnaggr(i) = locnaggr(i-1)
+      end do
+      locnaggr(0) = 0
+      !$omp end master 
+      !$omp barrier
+      !$omp  do schedule(static) 
+      do kk=0, nths-1
+        do ii=bnds(kk), bnds(kk+1)-1
+          if (ilaggr(ii) > 0) then 
+            kp = mod(ilaggr(ii),nths)
+            ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
+          end if
+        end do
+      end do
+      !$omp end do
+    end block
+    !$omp end parallel
+  end block
+  if (info /= 0) then
+    if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+#else
   step1: do ii=1, nr
+    if (info /= 0) cycle
     i = idxs(ii)
     if ((i<1).or.(i>nr)) then
       info=psb_err_internal_error_
       call psb_errpush(info,name)
-      goto 9999
+      cycle step1
+      !goto 9999
     end if
-    
+
     if (ilaggr(i) == -(nr+1)) then
       nz         = (acsr%irp(i+1)-acsr%irp(i))
       if ((nz<0).or.(nz>size(icol))) then
         info=psb_err_internal_error_
         call psb_errpush(info,name)
-        goto 9999
+        cycle step1
+        !goto 9999
       end if
 
       icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
@@ -176,7 +352,7 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       !
       ! Build the set of all strongly coupled nodes 
       !
-      ip = 0 
+      ip = 0
       do k=1, nz
         j   = icol(k)
         if ((1<=j).and.(j<=nr)) then 
@@ -194,8 +370,7 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       ! contains I even if it does not look like it from matrix)
       !
       disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
-      if (disjoint) then 
-        icnt      = icnt + 1 
+      if (disjoint) then       
         naggr     = naggr + 1
         do k=1, ip
           ilaggr(icol(k)) = naggr
@@ -204,16 +379,22 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     endif
   enddo step1
-  
+#endif
   if (debug_level >= psb_debug_outer_) then 
     write(debug_unit,*) me,' ',trim(name),&
-         & ' Check 1:',count(ilaggr == -(nr+1))
+         & ' Check   1:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
   end if
-
+  if (do_timings) call psb_toc(idx_soc1_p1)
+  if (do_timings) call psb_tic(idx_soc1_p2)
   !
   ! Phase two: join the neighbours
   !
+  !$omp workshare
   tmpaggr = ilaggr
+  !$omp end workshare
+  !$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,theta)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip,cpling)
   step2: do ii=1,nr
     i = idxs(ii)
 
@@ -244,8 +425,15 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     end if
   end do step2
+  !$omp end parallel do
+  if (do_timings) call psb_toc(idx_soc1_p2)
+  if (debug_level >= psb_debug_outer_) then 
+    write(debug_unit,*) me,' ',trim(name),&
+         & ' Check 1.5:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
+  end if
 
-
+  if (do_timings) call psb_tic(idx_soc1_p3)
   !
   ! Phase three: sweep over leftovers, if any 
   !
@@ -274,7 +462,6 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         end if
       enddo
       if (ip > 0) then
-        icnt      = icnt + 1 
         naggr     = naggr + 1
         ilaggr(i) = naggr
         do k=1, ip
@@ -292,7 +479,10 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   end do step3
 
   ! Any leftovers?
+  !$omp parallel do schedule(static) shared(ilaggr,info)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip)
   do i=1, nr
+    if (info /= 0) cycle
     if (ilaggr(i) < 0) then
       nz = (acsr%irp(i+1)-acsr%irp(i))
       if (nz == 1) then
@@ -303,15 +493,18 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         ! other processes. 
         ilaggr(i) = -(nrglob+nr)
       else
+        !$omp atomic write
         info=psb_err_internal_error_
+        !$omp end atomic
         call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
-        goto 9999
+        cycle 
       endif
     end if
   end do
-
+  !$omp end parallel do
+  if (info /= 0) goto 9999
+  if (do_timings) call psb_toc(idx_soc1_p3)
   if (naggr > ncol) then 
-    !write(0,*) name,'Error : naggr > ncol',naggr,ncol
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
     goto 9999
@@ -336,9 +529,13 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nlaggr(:) = 0
   nlaggr(me+1) = naggr
   call psb_sum(ctxt,nlaggr(1:np))
+  if (debug_level >= psb_debug_outer_) then 
+    write(debug_unit,*) me,' ',trim(name),&
+         & ' Check   2:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
+  end if
 
   call acsr%free()
-
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_s_soc2_map_bld.F90

@@ -68,9 +68,12 @@
 !
 subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
 
-  use psb_base_mod
+  use psb_base_mod 
   use amg_base_prec_type
   use amg_s_inner_mod
+#if defined(OPENMP)
+  use omp_lib
+#endif
 
   implicit none
 
@@ -99,6 +102,9 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_) :: np, me
   integer(psb_ipk_) :: nrow, ncol, n_ne
   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.
 
   info=psb_success_
   name = 'amg_soc2_map_bld'
@@ -114,6 +120,14 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nrow   = desc_a%get_local_rows()
   ncol   = desc_a%get_local_cols()
   nrglob = desc_a%get_global_rows()
+  if ((do_timings).and.(idx_soc2_p0==-1))       &
+       & idx_soc2_p0 = psb_get_timer_idx("SOC2_MAP: phase0")
+  if ((do_timings).and.(idx_soc2_p1==-1))       &
+       & idx_soc2_p1 = psb_get_timer_idx("SOC2_MAP: phase1")
+  if ((do_timings).and.(idx_soc2_p2==-1))       &
+       & idx_soc2_p2 = psb_get_timer_idx("SOC2_MAP: phase2")
+  if ((do_timings).and.(idx_soc2_p3==-1))       &
+       & idx_soc2_p3 = psb_get_timer_idx("SOC2_MAP: phase3")
 
   nr = a%get_nrows()
   nc = a%get_ncols()
@@ -125,6 +139,7 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
     goto 9999
   end if
 
+  if (do_timings) call psb_tic(idx_soc2_p0)
   diag = a%get_diag(info)
   if(info /= psb_success_) then
     info=psb_err_from_subroutine_
@@ -137,55 +152,217 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   ! 
   call a%cp_to(muij)
   if (clean_zeros) call muij%clean_zeros(info)
+  !$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
   do i=1, nr
     do k=muij%irp(i),muij%irp(i+1)-1
       j = muij%ja(k)
       if (j<= nr) muij%val(k) = abs(muij%val(k))/sqrt(abs(diag(i)*diag(j)))
     end do
   end do
-
+  !$omp end parallel do 
   !
   ! Compute the 1-neigbour; mark strong links with +1, weak links with -1
   !
   call s_neigh_coo%allocate(nr,nr,muij%get_nzeros())
-  ip = 0 
+  !$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
   do i=1, nr
     do k=muij%irp(i),muij%irp(i+1)-1
       j = muij%ja(k)
+      s_neigh_coo%ia(k)  = i
+      s_neigh_coo%ja(k)  = j
       if (j<=nr) then 
-        ip = ip + 1
-        s_neigh_coo%ia(ip)  = i
-        s_neigh_coo%ja(ip)  = j
         if (real(muij%val(k)) >= theta) then 
-          s_neigh_coo%val(ip) = sone
+          s_neigh_coo%val(k) = sone
         else
-          s_neigh_coo%val(ip) = -sone
+          s_neigh_coo%val(k) = -sone
         end if
+      else
+        s_neigh_coo%val(k) = -sone        
       end if
     end do
   end do
+  !$omp end parallel do
   !write(*,*) 'S_NEIGH: ',nr,ip
-  call s_neigh_coo%set_nzeros(ip)
+  call s_neigh_coo%set_nzeros(muij%get_nzeros())
   call s_neigh%mv_from_coo(s_neigh_coo,info)
 
-  if (iorder == amg_aggr_ord_nat_) then 
+  if (iorder == amg_aggr_ord_nat_) then
+    
+    !$omp parallel do private(i) shared(ilaggr,idxs) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       idxs(i)   = i 
     end do
+    !$omp end parallel do 
   else 
+    !$omp parallel do private(i) shared(ilaggr,idxs,muij)  schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       ideg(i)   = muij%irp(i+1) - muij%irp(i)
     end do
+    !$omp end parallel do
     call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
   end if
 
+  if (do_timings) call psb_toc(idx_soc2_p0)
+  if (do_timings) call psb_tic(idx_soc2_p1)
 
   !
   ! Phase one: Start with disjoint groups.
   ! 
   naggr = 0
+#if defined(OPENMP)
+  block
+    integer(psb_ipk_), allocatable  :: bnds(:), locnaggr(:)
+    integer(psb_ipk_) :: myth,nths, kk
+    ! The parallelization makes use of a locaggr(:) array; each thread
+    ! keeps its own version of naggr, and when the loop ends, a prefix is applied
+    ! to locnaggr to determine:
+    ! 1. The total number of aggregaters NAGGR;
+    ! 2. How much should each thread shift its own aggregates
+    ! Part 2 requires to keep track of which thread defined each entry
+    ! of ilaggr(), so that each entry can be adjusted correctly: even
+    ! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
+    ! been set because it is strongly connected to an entry J belonging to a
+    ! different thread. 
+
+    !$omp parallel shared(s_neigh,bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
+    !$omp private(icol,val,myth,kk) 
+    block
+      integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz,nc,i,j,m,nz,ilg,ip,rsz,ip1,nzcnt
+      integer(psb_lpk_) :: itmp
+      !$omp master
+      nths = omp_get_num_threads()
+      allocate(bnds(0:nths),locnaggr(0:nths+1))
+      locnaggr(:) = 0
+      bnds(0) = 1
+      !$omp end master      
+      !$omp barrier
+      myth = omp_get_thread_num()
+      rsz = nr/nths
+      if (myth < mod(nr,nths)) rsz = rsz + 1
+      bnds(myth+1) = rsz
+      !$omp barrier
+      !$omp master
+      do i=1,nths
+        bnds(i) = bnds(i) + bnds(i-1)
+      end do
+      info = 0
+      !$omp end master
+      !$omp barrier
+
+      !$omp do schedule(static) private(disjoint) 
+      do kk=0, nths-1
+        step1: do ii=bnds(kk), bnds(kk+1)-1
+          i = idxs(ii)
+          if (info /= 0) then
+            write(0,*) ' Step1:',kk,ii,i,info
+            cycle step1
+          end if
+          if ((i<1).or.(i>nr)) then
+            !$omp atomic write
+            info=psb_err_internal_error_
+            !$omp end atomic 
+            call psb_errpush(info,name)
+            cycle step1
+            !goto 9999
+          end if
+
+
+          if (ilaggr(i) == -(nr+1)) then 
+            !
+            ! Get the 1-neighbourhood of I 
+            !
+            ip1 = s_neigh%irp(i)
+            nz  = s_neigh%irp(i+1)-ip1
+            !
+            ! If the neighbourhood only contains I, skip it
+            !
+            if (nz ==0) then
+              ilaggr(i) = 0
+              cycle step1
+            end if
+            if ((nz==1).and.(s_neigh%ja(ip1)==i)) then
+              ilaggr(i) = 0
+              cycle step1
+            end if
+
+            nzcnt = count(real(s_neigh%val(ip1:ip1+nz-1)) > 0)
+            icol(1:nzcnt) = pack(s_neigh%ja(ip1:ip1+nz-1),(real(s_neigh%val(ip1:ip1+nz-1)) > 0))
+            disjoint = all(ilaggr(icol(1:nzcnt)) == -(nr+1)) 
+
+            !
+            ! If the whole strongly coupled neighborhood of I is
+            ! as yet unconnected, turn it into the next aggregate.
+            ! Same if ip==0 (in which case, neighborhood only
+            ! contains I even if it does not look like it from matrix)
+            ! The fact that DISJOINT is private and not under lock
+            ! generates a certain un-repeatability, in that between
+            ! computing DISJOINT and assigning, another thread might
+            ! alter the values of ILAGGR.
+            ! However, a certain unrepeatability is already present
+            ! because the sequence of aggregates is computed with a
+            ! different order than in serial mode.
+            ! In any case, even if the enteries of ILAGGR may be
+            ! overwritten, the important thing is that each entry is
+            ! consistent and they generate a correct aggregation map.
+            !
+            if (disjoint) then
+              locnaggr(kk)     = locnaggr(kk) + 1
+              itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
+              if (itmp < (bnds(kk)-1+locnaggr(kk))) then
+                !$omp atomic update
+                info = max(12345678,info)
+                !$omp end atomic
+                cycle step1
+              end if
+              !$omp atomic write
+              ilaggr(i) = itmp
+              !$omp end atomic
+              do k=1, nzcnt
+                !$omp atomic write
+                ilaggr(icol(k)) = itmp
+                !$omp end atomic
+              end do
+            end if
+          end if
+        enddo step1
+      end do
+      !$omp end do
+
+      !$omp master
+      naggr = sum(locnaggr(0:nths-1))
+      do i=1,nths
+        locnaggr(i) = locnaggr(i) + locnaggr(i-1)
+      end do
+      do i=nths+1,1,-1
+        locnaggr(i) = locnaggr(i-1)
+      end do
+      locnaggr(0) = 0
+      !write(0,*) 'LNAG ',locnaggr(nths+1)
+      !$omp end master 
+      !$omp barrier
+      !$omp  do schedule(static) 
+      do kk=0, nths-1
+        do ii=bnds(kk), bnds(kk+1)-1
+          if (ilaggr(ii) > 0) then 
+            kp = mod(ilaggr(ii),nths)
+            ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
+          end if
+        end do
+      end do
+      !$omp end do
+    end block
+    !$omp end parallel
+  end block
+  if (info /= 0) then
+    if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+#else
   icnt = 0
   step1: do ii=1, nr
     i = idxs(ii)
@@ -224,16 +401,21 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     endif
   enddo step1
-  
+#endif  
   if (debug_level >= psb_debug_outer_) then 
     write(debug_unit,*) me,' ',trim(name),&
          & ' Check 1:',count(ilaggr == -(nr+1))
   end if
-
+  if (do_timings) call psb_toc(idx_soc2_p1)
+  if (do_timings) call psb_tic(idx_soc2_p2)
   !
   ! Phase two: join the neighbours
   !
+  !$omp workshare
   tmpaggr = ilaggr
+  !$omp end workshare
+  !$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,muij,s_neigh)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip,cpling)
   step2: do ii=1,nr
     i = idxs(ii)
 
@@ -259,8 +441,9 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     end if
   end do step2
-
-
+  !$omp end parallel do
+  if (do_timings) call psb_toc(idx_soc2_p2)
+  if (do_timings) call psb_tic(idx_soc2_p3)
   !
   ! Phase three: sweep over leftovers, if any 
   !
@@ -294,6 +477,8 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   end do step3
 
   ! Any leftovers?
+  !$omp parallel do schedule(static) shared(ilaggr,s_neigh,info)& 
+  !$omp     private(ii,i,j,k)
   do i=1, nr
     if (ilaggr(i) <= 0) then
       nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
@@ -305,13 +490,17 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         ! other processes. 
         ilaggr(i) = -(nrglob+nr)
       else
+        !$omp atomic write
         info=psb_err_internal_error_
+        !$omp end atomic
         call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
-        goto 9999
+        cycle
       endif
     end if
   end do
-
+  !$omp end parallel do
+  if (info /= 0) goto 9999
+  if (do_timings) call psb_toc(idx_soc2_p3)  
   if (naggr > ncol) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')

amgprec/impl/aggregator/amg_saggrmat_smth_bld.f90

@@ -140,6 +140,9 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   real(psb_spk_)     :: anorm, omega, tmp, dg, theta
   logical, parameter :: debug_new=.false.
   character(len=80) :: filename
+  logical, parameter :: do_timings=.false.
+  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
 
   name='amg_aggrmat_smth_bld'
   info=psb_success_
@@ -153,6 +156,23 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   ctxt = desc_a%get_context()
 
   call psb_info(ctxt, me, np)
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("DEC_SMTH_BLD: par_spspmm")
+  if ((do_timings).and.(idx_phase1==-1)) &
+       & idx_phase1 = psb_get_timer_idx("DEC_SMTH_BLD: phase1    ")
+  if ((do_timings).and.(idx_phase2==-1)) &
+       & idx_phase2 = psb_get_timer_idx("DEC_SMTH_BLD: phase2    ")
+  if ((do_timings).and.(idx_phase3==-1)) &
+       & idx_phase3 = psb_get_timer_idx("DEC_SMTH_BLD: phase3    ")
+  if ((do_timings).and.(idx_gtrans==-1)) &
+       & idx_gtrans = psb_get_timer_idx("DEC_SMTH_BLD: gtrans    ")
+  if ((do_timings).and.(idx_refine==-1)) &
+       & idx_refine = psb_get_timer_idx("DEC_SMTH_BLD: refine    ")
+  if ((do_timings).and.(idx_cdasb==-1)) &
+       & idx_cdasb = psb_get_timer_idx("DEC_SMTH_BLD: cdasb     ")
+  if ((do_timings).and.(idx_ptap==-1)) &
+       & idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld  ")
+
 
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
@@ -171,6 +191,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   ! naggr: number of local aggregates
   ! nrow: local rows. 
   ! 
+  if (do_timings) call psb_tic(idx_phase1)
 
   ! Get the diagonal D
   adiag = a%get_diag(info)
@@ -196,7 +217,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     !
     ! Build the filtered matrix Af from A
     ! 
-
+    !$OMP parallel do private(i,j,tmp,jd) schedule(static)
     do i=1, nrow
       tmp = szero
       jd  = -1 
@@ -214,11 +235,13 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
         acsrf%val(jd)=acsrf%val(jd)-tmp
       end if
     enddo
+    !$OMP end parallel do 
     ! Take out zeroed terms 
     call acsrf%clean_zeros(info)
   end if
 
 
+  !$OMP parallel do private(i) schedule(static)
   do i=1,size(adiag)
     if (adiag(i) /= szero) then
       adiag(i) = sone / adiag(i)
@@ -226,7 +249,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
       adiag(i) = sone
     end if
   end do
-
+  !$OMP end parallel do 
   if (parms%aggr_omega_alg == amg_eig_est_) then 
 
     if (parms%aggr_eig == amg_max_norm_) then 
@@ -252,8 +275,9 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
     goto 9999
   end if
+  if (do_timings) call psb_toc(idx_phase1)
 
-  
+  if (do_timings) call psb_tic(idx_phase2)
   call acsrf%scal(adiag,info)
   if (info /= psb_success_) goto 9999
 
@@ -267,6 +291,8 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   call psb_cdasb(desc_ac,info)
   call psb_cd_reinit(desc_ac,info)
+  if (do_timings) call psb_toc(idx_phase2)
+  if (do_timings) call psb_tic(idx_phase3)
   !
   ! Build the smoothed prolongator using either A or Af
   !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
@@ -279,8 +305,8 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
     goto 9999
   end if
-
-
+  if (do_timings) call psb_toc(idx_phase3)
+  if (do_timings) call psb_tic(idx_ptap)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done SPSPMM 1'
@@ -292,7 +318,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   call op_prol%mv_from(coo_prol)
   call op_restr%mv_from(coo_restr)
-
+  if (do_timings) call psb_toc(idx_ptap)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done smooth_aggregate '

amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90

@@ -97,6 +97,8 @@ subroutine  amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
   integer(psb_lpk_)   :: ntaggr
   integer(psb_ipk_)   :: debug_level, debug_unit
   logical             :: clean_zeros
+  integer(psb_ipk_), save :: idx_map_bld=-1, idx_map_tprol=-1
+  logical, parameter      :: do_timings=.false.
 
   name='amg_z_dec_aggregator_tprol'
   call psb_erractionsave(err_act)
@@ -108,6 +110,10 @@ subroutine  amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  if ((do_timings).and.(idx_map_bld==-1))       &
+       & idx_map_bld = psb_get_timer_idx("DEC_TPROL: map_bld")
+  if ((do_timings).and.(idx_map_tprol==-1))     &
+       & idx_map_tprol = psb_get_timer_idx("DEC_TPROL: map_tprol")
 
   call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
        &   amg_mult_ml_,is_legal_ml_cycle)
@@ -121,10 +127,14 @@ subroutine  amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
   ! The decoupled aggregator based on SOC measures ignores
   ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
   !
+  if (do_timings) call psb_tic(idx_map_bld)
   clean_zeros = ag%do_clean_zeros
   call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+  if (do_timings) call psb_toc(idx_map_bld)
+  if (do_timings) call psb_tic(idx_map_tprol)
 
   if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+  if (do_timings) call psb_toc(idx_map_tprol)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_z_ptap_bld.f90

@@ -76,7 +76,7 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
   integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
   logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
+  integer(psb_ipk_), save :: idx_spspmm=-1, idx_cpytrans1=-1, idx_cpytrans2=-1
 
   name='amg_ptap_bld'
   if(psb_get_errstatus().ne.0) return 
@@ -93,7 +93,11 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   ncol  = desc_a%get_local_cols()
 
   if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+       & idx_spspmm = psb_get_timer_idx("PTAP_BLD: par_spspmm")
+  if ((do_timings).and.(idx_cpytrans1==-1)) &
+       & idx_cpytrans1 = psb_get_timer_idx("PTAP_BLD: cpy&trans1")
+  if ((do_timings).and.(idx_cpytrans2==-1)) &
+       & idx_cpytrans2 = psb_get_timer_idx("PTAP_BLD: cpy&trans2")
 
   naggr   = nlaggr(me+1)
   ntaggr  = sum(nlaggr)
@@ -128,6 +132,7 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
   ! Ok first product done.
 
   if (present(desc_ax)) then
+    if (do_timings) call psb_tic(idx_cpytrans1)
     block 
       call coo_prol%cp_to_coo(coo_restr,info)
       call coo_restr%set_ncols(desc_ac%get_local_cols())
@@ -137,7 +142,7 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
       call coo_restr%set_ncols(desc_ax%get_local_cols())
     end block
     call csr_restr%cp_from_coo(coo_restr,info)
-
+    if (do_timings) call psb_toc(idx_cpytrans1)
     if (info /= psb_success_) then 
       call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
       goto 9999
@@ -167,27 +172,28 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
 
     call coo_restr%transp()
     nzl = coo_restr%get_nzeros()
-    nrl = desc_ac%get_local_rows() 
-    i=0
+    nrl = desc_ac%get_local_rows()
+    call coo_restr%fix(info)
+    i=coo_restr%get_nzeros()
     !
     ! Only keep local rows
     !
-    do k=1, nzl
-      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
-        i = i+1
-        coo_restr%val(i) = coo_restr%val(k)
-        coo_restr%ia(i)  = coo_restr%ia(k)
-        coo_restr%ja(i)  = coo_restr%ja(k)
+    search: do k=i,1,-1
+      if (coo_restr%ia(k) <= nrl) then
+        call coo_restr%set_nzeros(k)
+        exit search
       end if
-    end do
-    call coo_restr%set_nzeros(i)
-    call coo_restr%fix(info) 
+    end do search
+
     nzl  = coo_restr%get_nzeros()
     call coo_restr%set_nrows(desc_ac%get_local_rows())
     call coo_restr%set_ncols(desc_a%get_local_cols())
     if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    if (do_timings) call psb_tic(idx_cpytrans2)
+        
     call csr_restr%cp_from_coo(coo_restr,info)
 
+    if (do_timings) call psb_toc(idx_cpytrans2)
     if (info /= psb_success_) then 
       call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
       goto 9999

amgprec/impl/aggregator/amg_z_soc1_map_bld.F90

@@ -72,7 +72,9 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   use psb_base_mod
   use amg_base_prec_type
   use amg_z_inner_mod
-
+#if defined(OPENMP)
+  use omp_lib
+#endif
   implicit none
 
   ! Arguments
@@ -85,7 +87,7 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_), intent(out)               :: info
 
   ! Local variables
-  integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),&
+  integer(psb_ipk_), allocatable :: neigh(:), irow(:), icol(:),&
        & ideg(:), idxs(:)
   integer(psb_lpk_), allocatable :: tmpaggr(:)
   complex(psb_dpk_), allocatable  :: val(:), diag(:)
@@ -99,6 +101,9 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_)   :: nrow, ncol, n_ne
   integer(psb_lpk_)   :: nrglob
   character(len=20)   :: name, ch_err
+  integer(psb_ipk_), save :: idx_soc1_p1=-1, idx_soc1_p2=-1, idx_soc1_p3=-1
+  integer(psb_ipk_), save :: idx_soc1_p0=-1
+  logical, parameter      :: do_timings=.true.
 
   info=psb_success_
   name = 'amg_soc1_map_bld'
@@ -114,6 +119,14 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nrow   = desc_a%get_local_rows()
   ncol   = desc_a%get_local_cols()
   nrglob = desc_a%get_global_rows()
+  if ((do_timings).and.(idx_soc1_p0==-1))       &
+       & idx_soc1_p0 = psb_get_timer_idx("SOC1_MAP: phase0")
+  if ((do_timings).and.(idx_soc1_p1==-1))       &
+       & idx_soc1_p1 = psb_get_timer_idx("SOC1_MAP: phase1")
+  if ((do_timings).and.(idx_soc1_p2==-1))       &
+       & idx_soc1_p2 = psb_get_timer_idx("SOC1_MAP: phase2")
+  if ((do_timings).and.(idx_soc1_p3==-1))       &
+       & idx_soc1_p3 = psb_get_timer_idx("SOC1_MAP: phase3")
 
   nr = a%get_nrows()
   nc = a%get_ncols()
@@ -133,41 +146,204 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
     goto 9999
   end if
 
+  if (do_timings) call psb_tic(idx_soc1_p0)
   call a%cp_to(acsr)
+  if (do_timings) call psb_toc(idx_soc1_p0)
   if (clean_zeros) call acsr%clean_zeros(info)
   if (iorder == amg_aggr_ord_nat_) then 
+    !$omp parallel do private(i) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
-      idxs(i)   = i 
+      idxs(i)   = i
     end do
-  else 
+    !$omp end parallel do 
+  else
+    !$omp parallel do private(i) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       ideg(i)   = acsr%irp(i+1) - acsr%irp(i)
     end do
+    !$omp end parallel do 
     call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
   end if
-
+  if (do_timings) call psb_tic(idx_soc1_p1)
 
   !
   ! Phase one: Start with disjoint groups.
   ! 
   naggr = 0
-  icnt = 0
+#if defined(OPENMP)
+  block
+    integer(psb_ipk_), allocatable  :: bnds(:), locnaggr(:)
+    integer(psb_ipk_) :: myth,nths, kk
+    ! The parallelization makes use of a locaggr(:) array; each thread
+    ! keeps its own version of naggr, and when the loop ends, a prefix is applied
+    ! to locnaggr to determine:
+    ! 1. The total number of aggregaters NAGGR;
+    ! 2. How much should each thread shift its own aggregates
+    ! Part 2 requires to keep track of which thread defined each entry
+    ! of ilaggr(), so that each entry can be adjusted correctly: even
+    ! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
+    ! been set because it is strongly connected to an entry J belonging to a
+    ! different thread. 
+
+    !$omp parallel shared(bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
+    !$omp private(icol,val,myth,kk) 
+    block
+      integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz, nc, i,j,m, nz, ilg,  ip, rsz
+      integer(psb_lpk_) :: itmp
+      !$omp master
+      nths = omp_get_num_threads()
+      allocate(bnds(0:nths),locnaggr(0:nths+1))
+      locnaggr(:) = 0
+      bnds(0) = 1
+      !$omp end master      
+      !$omp barrier
+      myth = omp_get_thread_num()
+      rsz = nr/nths
+      if (myth < mod(nr,nths)) rsz = rsz + 1
+      bnds(myth+1) = rsz
+      !$omp barrier
+      !$omp master
+      do i=1,nths
+        bnds(i) = bnds(i) + bnds(i-1)
+      end do
+      info = 0
+      !$omp end master
+      !$omp barrier
+      
+      !$omp do schedule(static) private(disjoint) 
+      do kk=0, nths-1
+        step1: do ii=bnds(kk), bnds(kk+1)-1
+          i = idxs(ii)          
+          if (info /= 0) cycle step1
+          if ((i<1).or.(i>nr)) then
+            !$omp atomic write
+            info=psb_err_internal_error_
+            !$omp end atomic 
+            call psb_errpush(info,name)
+            cycle step1
+            !goto 9999
+          end if
+            
+          if (ilaggr(i) == -(nr+1)) then
+            nz         = (acsr%irp(i+1)-acsr%irp(i))
+            if ((nz<0).or.(nz>size(icol))) then
+              !$omp atomic write
+              info=psb_err_internal_error_
+              !$omp end atomic 
+              call psb_errpush(info,name)
+              cycle step1
+              !goto 9999
+            end if
+
+            icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
+            val(1:nz)  = acsr%val(acsr%irp(i):acsr%irp(i+1)-1) 
+
+            !
+            ! Build the set of all strongly coupled nodes 
+            !
+            ip = 0
+            do k=1, nz
+              j   = icol(k)
+              ! If any of the neighbours is already assigned,
+              ! we will not reset. 
+              if (j>nr) cycle step1
+              if (ilaggr(j) > 0) cycle step1
+              if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
+                ip = ip + 1
+                icol(ip) = icol(k)
+              end if
+            enddo
+            
+            !
+            ! If the whole strongly coupled neighborhood of I is
+            ! as yet unconnected, turn it into the next aggregate.
+            ! Same if ip==0 (in which case, neighborhood only
+            ! contains I even if it does not look like it from matrix)
+            ! The fact that DISJOINT is private and not under lock
+            ! generates a certain un-repeatability, in that between
+            ! computing DISJOINT and assigning, another thread might
+            ! alter the values of ILAGGR.
+            ! However, a certain unrepeatability is already present
+            ! because the sequence of aggregates is computed with a
+            ! different order than in serial mode.
+            ! In any case, even if the enteries of ILAGGR may be
+            ! overwritten, the important thing is that each entry is
+            ! consistent and they generate a correct aggregation map.
+            !
+            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
+              if (itmp < (bnds(kk)-1+locnaggr(kk))) then
+                !$omp atomic update
+                info = max(12345678,info)
+                !$omp end atomic
+                cycle step1
+              end if
+              !$omp atomic write
+              ilaggr(i) = itmp
+              !$omp end atomic
+              do k=1, ip
+                !$omp atomic write
+                ilaggr(icol(k)) = itmp
+                !$omp end atomic
+              end do
+            end if
+          end if
+        enddo step1
+      end do
+      !$omp end do
+
+      !$omp master
+      naggr = sum(locnaggr(0:nths-1))
+      do i=1,nths
+        locnaggr(i) = locnaggr(i) + locnaggr(i-1)
+      end do
+      do i=nths+1,1,-1
+        locnaggr(i) = locnaggr(i-1)
+      end do
+      locnaggr(0) = 0
+      !$omp end master 
+      !$omp barrier
+      !$omp  do schedule(static) 
+      do kk=0, nths-1
+        do ii=bnds(kk), bnds(kk+1)-1
+          if (ilaggr(ii) > 0) then 
+            kp = mod(ilaggr(ii),nths)
+            ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
+          end if
+        end do
+      end do
+      !$omp end do
+    end block
+    !$omp end parallel
+  end block
+  if (info /= 0) then
+    if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+#else
   step1: do ii=1, nr
+    if (info /= 0) cycle
     i = idxs(ii)
     if ((i<1).or.(i>nr)) then
       info=psb_err_internal_error_
       call psb_errpush(info,name)
-      goto 9999
+      cycle step1
+      !goto 9999
     end if
-    
+
     if (ilaggr(i) == -(nr+1)) then
       nz         = (acsr%irp(i+1)-acsr%irp(i))
       if ((nz<0).or.(nz>size(icol))) then
         info=psb_err_internal_error_
         call psb_errpush(info,name)
-        goto 9999
+        cycle step1
+        !goto 9999
       end if
 
       icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
@@ -176,7 +352,7 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       !
       ! Build the set of all strongly coupled nodes 
       !
-      ip = 0 
+      ip = 0
       do k=1, nz
         j   = icol(k)
         if ((1<=j).and.(j<=nr)) then 
@@ -194,8 +370,7 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       ! contains I even if it does not look like it from matrix)
       !
       disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
-      if (disjoint) then 
-        icnt      = icnt + 1 
+      if (disjoint) then       
         naggr     = naggr + 1
         do k=1, ip
           ilaggr(icol(k)) = naggr
@@ -204,16 +379,22 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     endif
   enddo step1
-  
+#endif
   if (debug_level >= psb_debug_outer_) then 
     write(debug_unit,*) me,' ',trim(name),&
-         & ' Check 1:',count(ilaggr == -(nr+1))
+         & ' Check   1:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
   end if
-
+  if (do_timings) call psb_toc(idx_soc1_p1)
+  if (do_timings) call psb_tic(idx_soc1_p2)
   !
   ! Phase two: join the neighbours
   !
+  !$omp workshare
   tmpaggr = ilaggr
+  !$omp end workshare
+  !$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,theta)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip,cpling)
   step2: do ii=1,nr
     i = idxs(ii)
 
@@ -244,8 +425,15 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     end if
   end do step2
+  !$omp end parallel do
+  if (do_timings) call psb_toc(idx_soc1_p2)
+  if (debug_level >= psb_debug_outer_) then 
+    write(debug_unit,*) me,' ',trim(name),&
+         & ' Check 1.5:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
+  end if
 
-
+  if (do_timings) call psb_tic(idx_soc1_p3)
   !
   ! Phase three: sweep over leftovers, if any 
   !
@@ -274,7 +462,6 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         end if
       enddo
       if (ip > 0) then
-        icnt      = icnt + 1 
         naggr     = naggr + 1
         ilaggr(i) = naggr
         do k=1, ip
@@ -292,7 +479,10 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   end do step3
 
   ! Any leftovers?
+  !$omp parallel do schedule(static) shared(ilaggr,info)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip)
   do i=1, nr
+    if (info /= 0) cycle
     if (ilaggr(i) < 0) then
       nz = (acsr%irp(i+1)-acsr%irp(i))
       if (nz == 1) then
@@ -303,15 +493,18 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         ! other processes. 
         ilaggr(i) = -(nrglob+nr)
       else
+        !$omp atomic write
         info=psb_err_internal_error_
+        !$omp end atomic
         call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
-        goto 9999
+        cycle 
       endif
     end if
   end do
-
+  !$omp end parallel do
+  if (info /= 0) goto 9999
+  if (do_timings) call psb_toc(idx_soc1_p3)
   if (naggr > ncol) then 
-    !write(0,*) name,'Error : naggr > ncol',naggr,ncol
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
     goto 9999
@@ -336,9 +529,13 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nlaggr(:) = 0
   nlaggr(me+1) = naggr
   call psb_sum(ctxt,nlaggr(1:np))
+  if (debug_level >= psb_debug_outer_) then 
+    write(debug_unit,*) me,' ',trim(name),&
+         & ' Check   2:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
+         & count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
+  end if
 
   call acsr%free()
-
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_z_soc2_map_bld.F90

@@ -68,9 +68,12 @@
 !
 subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
 
-  use psb_base_mod
+  use psb_base_mod 
   use amg_base_prec_type
   use amg_z_inner_mod
+#if defined(OPENMP)
+  use omp_lib
+#endif
 
   implicit none
 
@@ -99,6 +102,9 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   integer(psb_ipk_) :: np, me
   integer(psb_ipk_) :: nrow, ncol, n_ne
   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.
 
   info=psb_success_
   name = 'amg_soc2_map_bld'
@@ -114,6 +120,14 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   nrow   = desc_a%get_local_rows()
   ncol   = desc_a%get_local_cols()
   nrglob = desc_a%get_global_rows()
+  if ((do_timings).and.(idx_soc2_p0==-1))       &
+       & idx_soc2_p0 = psb_get_timer_idx("SOC2_MAP: phase0")
+  if ((do_timings).and.(idx_soc2_p1==-1))       &
+       & idx_soc2_p1 = psb_get_timer_idx("SOC2_MAP: phase1")
+  if ((do_timings).and.(idx_soc2_p2==-1))       &
+       & idx_soc2_p2 = psb_get_timer_idx("SOC2_MAP: phase2")
+  if ((do_timings).and.(idx_soc2_p3==-1))       &
+       & idx_soc2_p3 = psb_get_timer_idx("SOC2_MAP: phase3")
 
   nr = a%get_nrows()
   nc = a%get_ncols()
@@ -125,6 +139,7 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
     goto 9999
   end if
 
+  if (do_timings) call psb_tic(idx_soc2_p0)
   diag = a%get_diag(info)
   if(info /= psb_success_) then
     info=psb_err_from_subroutine_
@@ -137,55 +152,217 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   ! 
   call a%cp_to(muij)
   if (clean_zeros) call muij%clean_zeros(info)
+  !$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
   do i=1, nr
     do k=muij%irp(i),muij%irp(i+1)-1
       j = muij%ja(k)
       if (j<= nr) muij%val(k) = abs(muij%val(k))/sqrt(abs(diag(i)*diag(j)))
     end do
   end do
-
+  !$omp end parallel do 
   !
   ! Compute the 1-neigbour; mark strong links with +1, weak links with -1
   !
   call s_neigh_coo%allocate(nr,nr,muij%get_nzeros())
-  ip = 0 
+  !$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
   do i=1, nr
     do k=muij%irp(i),muij%irp(i+1)-1
       j = muij%ja(k)
+      s_neigh_coo%ia(k)  = i
+      s_neigh_coo%ja(k)  = j
       if (j<=nr) then 
-        ip = ip + 1
-        s_neigh_coo%ia(ip)  = i
-        s_neigh_coo%ja(ip)  = j
         if (real(muij%val(k)) >= theta) then 
-          s_neigh_coo%val(ip) = done
+          s_neigh_coo%val(k) = done
         else
-          s_neigh_coo%val(ip) = -done
+          s_neigh_coo%val(k) = -done
         end if
+      else
+        s_neigh_coo%val(k) = -done        
       end if
     end do
   end do
+  !$omp end parallel do
   !write(*,*) 'S_NEIGH: ',nr,ip
-  call s_neigh_coo%set_nzeros(ip)
+  call s_neigh_coo%set_nzeros(muij%get_nzeros())
   call s_neigh%mv_from_coo(s_neigh_coo,info)
 
-  if (iorder == amg_aggr_ord_nat_) then 
+  if (iorder == amg_aggr_ord_nat_) then
+    
+    !$omp parallel do private(i) shared(ilaggr,idxs) schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       idxs(i)   = i 
     end do
+    !$omp end parallel do 
   else 
+    !$omp parallel do private(i) shared(ilaggr,idxs,muij)  schedule(static)
     do i=1, nr
       ilaggr(i) = -(nr+1)
       ideg(i)   = muij%irp(i+1) - muij%irp(i)
     end do
+    !$omp end parallel do
     call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
   end if
 
+  if (do_timings) call psb_toc(idx_soc2_p0)
+  if (do_timings) call psb_tic(idx_soc2_p1)
 
   !
   ! Phase one: Start with disjoint groups.
   ! 
   naggr = 0
+#if defined(OPENMP)
+  block
+    integer(psb_ipk_), allocatable  :: bnds(:), locnaggr(:)
+    integer(psb_ipk_) :: myth,nths, kk
+    ! The parallelization makes use of a locaggr(:) array; each thread
+    ! keeps its own version of naggr, and when the loop ends, a prefix is applied
+    ! to locnaggr to determine:
+    ! 1. The total number of aggregaters NAGGR;
+    ! 2. How much should each thread shift its own aggregates
+    ! Part 2 requires to keep track of which thread defined each entry
+    ! of ilaggr(), so that each entry can be adjusted correctly: even
+    ! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
+    ! been set because it is strongly connected to an entry J belonging to a
+    ! different thread. 
+
+    !$omp parallel shared(s_neigh,bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
+    !$omp private(icol,val,myth,kk) 
+    block
+      integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz,nc,i,j,m,nz,ilg,ip,rsz,ip1,nzcnt
+      integer(psb_lpk_) :: itmp
+      !$omp master
+      nths = omp_get_num_threads()
+      allocate(bnds(0:nths),locnaggr(0:nths+1))
+      locnaggr(:) = 0
+      bnds(0) = 1
+      !$omp end master      
+      !$omp barrier
+      myth = omp_get_thread_num()
+      rsz = nr/nths
+      if (myth < mod(nr,nths)) rsz = rsz + 1
+      bnds(myth+1) = rsz
+      !$omp barrier
+      !$omp master
+      do i=1,nths
+        bnds(i) = bnds(i) + bnds(i-1)
+      end do
+      info = 0
+      !$omp end master
+      !$omp barrier
+
+      !$omp do schedule(static) private(disjoint) 
+      do kk=0, nths-1
+        step1: do ii=bnds(kk), bnds(kk+1)-1
+          i = idxs(ii)
+          if (info /= 0) then
+            write(0,*) ' Step1:',kk,ii,i,info
+            cycle step1
+          end if
+          if ((i<1).or.(i>nr)) then
+            !$omp atomic write
+            info=psb_err_internal_error_
+            !$omp end atomic 
+            call psb_errpush(info,name)
+            cycle step1
+            !goto 9999
+          end if
+
+
+          if (ilaggr(i) == -(nr+1)) then 
+            !
+            ! Get the 1-neighbourhood of I 
+            !
+            ip1 = s_neigh%irp(i)
+            nz  = s_neigh%irp(i+1)-ip1
+            !
+            ! If the neighbourhood only contains I, skip it
+            !
+            if (nz ==0) then
+              ilaggr(i) = 0
+              cycle step1
+            end if
+            if ((nz==1).and.(s_neigh%ja(ip1)==i)) then
+              ilaggr(i) = 0
+              cycle step1
+            end if
+
+            nzcnt = count(real(s_neigh%val(ip1:ip1+nz-1)) > 0)
+            icol(1:nzcnt) = pack(s_neigh%ja(ip1:ip1+nz-1),(real(s_neigh%val(ip1:ip1+nz-1)) > 0))
+            disjoint = all(ilaggr(icol(1:nzcnt)) == -(nr+1)) 
+
+            !
+            ! If the whole strongly coupled neighborhood of I is
+            ! as yet unconnected, turn it into the next aggregate.
+            ! Same if ip==0 (in which case, neighborhood only
+            ! contains I even if it does not look like it from matrix)
+            ! The fact that DISJOINT is private and not under lock
+            ! generates a certain un-repeatability, in that between
+            ! computing DISJOINT and assigning, another thread might
+            ! alter the values of ILAGGR.
+            ! However, a certain unrepeatability is already present
+            ! because the sequence of aggregates is computed with a
+            ! different order than in serial mode.
+            ! In any case, even if the enteries of ILAGGR may be
+            ! overwritten, the important thing is that each entry is
+            ! consistent and they generate a correct aggregation map.
+            !
+            if (disjoint) then
+              locnaggr(kk)     = locnaggr(kk) + 1
+              itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
+              if (itmp < (bnds(kk)-1+locnaggr(kk))) then
+                !$omp atomic update
+                info = max(12345678,info)
+                !$omp end atomic
+                cycle step1
+              end if
+              !$omp atomic write
+              ilaggr(i) = itmp
+              !$omp end atomic
+              do k=1, nzcnt
+                !$omp atomic write
+                ilaggr(icol(k)) = itmp
+                !$omp end atomic
+              end do
+            end if
+          end if
+        enddo step1
+      end do
+      !$omp end do
+
+      !$omp master
+      naggr = sum(locnaggr(0:nths-1))
+      do i=1,nths
+        locnaggr(i) = locnaggr(i) + locnaggr(i-1)
+      end do
+      do i=nths+1,1,-1
+        locnaggr(i) = locnaggr(i-1)
+      end do
+      locnaggr(0) = 0
+      !write(0,*) 'LNAG ',locnaggr(nths+1)
+      !$omp end master 
+      !$omp barrier
+      !$omp  do schedule(static) 
+      do kk=0, nths-1
+        do ii=bnds(kk), bnds(kk+1)-1
+          if (ilaggr(ii) > 0) then 
+            kp = mod(ilaggr(ii),nths)
+            ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
+          end if
+        end do
+      end do
+      !$omp end do
+    end block
+    !$omp end parallel
+  end block
+  if (info /= 0) then
+    if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+#else
   icnt = 0
   step1: do ii=1, nr
     i = idxs(ii)
@@ -224,16 +401,21 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     endif
   enddo step1
-  
+#endif  
   if (debug_level >= psb_debug_outer_) then 
     write(debug_unit,*) me,' ',trim(name),&
          & ' Check 1:',count(ilaggr == -(nr+1))
   end if
-
+  if (do_timings) call psb_toc(idx_soc2_p1)
+  if (do_timings) call psb_tic(idx_soc2_p2)
   !
   ! Phase two: join the neighbours
   !
+  !$omp workshare
   tmpaggr = ilaggr
+  !$omp end workshare
+  !$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,muij,s_neigh)& 
+  !$omp     private(ii,i,j,k,nz,icol,val,ip,cpling)
   step2: do ii=1,nr
     i = idxs(ii)
 
@@ -259,8 +441,9 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       end if
     end if
   end do step2
-
-
+  !$omp end parallel do
+  if (do_timings) call psb_toc(idx_soc2_p2)
+  if (do_timings) call psb_tic(idx_soc2_p3)
   !
   ! Phase three: sweep over leftovers, if any 
   !
@@ -294,6 +477,8 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   end do step3
 
   ! Any leftovers?
+  !$omp parallel do schedule(static) shared(ilaggr,s_neigh,info)& 
+  !$omp     private(ii,i,j,k)
   do i=1, nr
     if (ilaggr(i) <= 0) then
       nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
@@ -305,13 +490,17 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
         ! other processes. 
         ilaggr(i) = -(nrglob+nr)
       else
+        !$omp atomic write
         info=psb_err_internal_error_
+        !$omp end atomic
         call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
-        goto 9999
+        cycle
       endif
     end if
   end do
-
+  !$omp end parallel do
+  if (info /= 0) goto 9999
+  if (do_timings) call psb_toc(idx_soc2_p3)  
   if (naggr > ncol) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')

amgprec/impl/aggregator/amg_zaggrmat_smth_bld.f90

@@ -140,6 +140,9 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   real(psb_dpk_)     :: anorm, omega, tmp, dg, theta
   logical, parameter :: debug_new=.false.
   character(len=80) :: filename
+  logical, parameter :: do_timings=.false.
+  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
 
   name='amg_aggrmat_smth_bld'
   info=psb_success_
@@ -153,6 +156,23 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   ctxt = desc_a%get_context()
 
   call psb_info(ctxt, me, np)
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("DEC_SMTH_BLD: par_spspmm")
+  if ((do_timings).and.(idx_phase1==-1)) &
+       & idx_phase1 = psb_get_timer_idx("DEC_SMTH_BLD: phase1    ")
+  if ((do_timings).and.(idx_phase2==-1)) &
+       & idx_phase2 = psb_get_timer_idx("DEC_SMTH_BLD: phase2    ")
+  if ((do_timings).and.(idx_phase3==-1)) &
+       & idx_phase3 = psb_get_timer_idx("DEC_SMTH_BLD: phase3    ")
+  if ((do_timings).and.(idx_gtrans==-1)) &
+       & idx_gtrans = psb_get_timer_idx("DEC_SMTH_BLD: gtrans    ")
+  if ((do_timings).and.(idx_refine==-1)) &
+       & idx_refine = psb_get_timer_idx("DEC_SMTH_BLD: refine    ")
+  if ((do_timings).and.(idx_cdasb==-1)) &
+       & idx_cdasb = psb_get_timer_idx("DEC_SMTH_BLD: cdasb     ")
+  if ((do_timings).and.(idx_ptap==-1)) &
+       & idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld  ")
+
 
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
@@ -171,6 +191,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   ! naggr: number of local aggregates
   ! nrow: local rows. 
   ! 
+  if (do_timings) call psb_tic(idx_phase1)
 
   ! Get the diagonal D
   adiag = a%get_diag(info)
@@ -196,7 +217,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     !
     ! Build the filtered matrix Af from A
     ! 
-
+    !$OMP parallel do private(i,j,tmp,jd) schedule(static)
     do i=1, nrow
       tmp = zzero
       jd  = -1 
@@ -214,11 +235,13 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
         acsrf%val(jd)=acsrf%val(jd)-tmp
       end if
     enddo
+    !$OMP end parallel do 
     ! Take out zeroed terms 
     call acsrf%clean_zeros(info)
   end if
 
 
+  !$OMP parallel do private(i) schedule(static)
   do i=1,size(adiag)
     if (adiag(i) /= zzero) then
       adiag(i) = zone / adiag(i)
@@ -226,7 +249,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
       adiag(i) = zone
     end if
   end do
-
+  !$OMP end parallel do 
   if (parms%aggr_omega_alg == amg_eig_est_) then 
 
     if (parms%aggr_eig == amg_max_norm_) then 
@@ -252,8 +275,9 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
     goto 9999
   end if
+  if (do_timings) call psb_toc(idx_phase1)
 
-  
+  if (do_timings) call psb_tic(idx_phase2)
   call acsrf%scal(adiag,info)
   if (info /= psb_success_) goto 9999
 
@@ -267,6 +291,8 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   call psb_cdasb(desc_ac,info)
   call psb_cd_reinit(desc_ac,info)
+  if (do_timings) call psb_toc(idx_phase2)
+  if (do_timings) call psb_tic(idx_phase3)
   !
   ! Build the smoothed prolongator using either A or Af
   !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
@@ -279,8 +305,8 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
     call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
     goto 9999
   end if
-
-
+  if (do_timings) call psb_toc(idx_phase3)
+  if (do_timings) call psb_tic(idx_ptap)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done SPSPMM 1'
@@ -292,7 +318,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   call op_prol%mv_from(coo_prol)
   call op_restr%mv_from(coo_restr)
-
+  if (do_timings) call psb_toc(idx_ptap)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done smooth_aggregate '

amgprec/impl/aggregator/clean.cpp

@@ -0,0 +1,91 @@
+#include "MatchBoxPC.h"
+
+// TODO comment
+
+void clean(MilanLongInt NLVer,
+           MilanInt myRank,
+           MilanLongInt MessageIndex,
+           vector<MPI_Request> &SRequest,
+           vector<MPI_Status> &SStatus,
+           MilanInt BufferSize,
+           MilanLongInt *Buffer,
+           MilanLongInt msgActual,
+           MilanLongInt *msgActualSent,
+           MilanLongInt msgInd,
+           MilanLongInt *msgIndSent,
+           MilanLongInt NumMessagesBundled,
+           MilanReal *msgPercent)
+{
+    // Cleanup Phase
+
+#pragma omp parallel
+    {
+#pragma omp master
+        {
+#pragma omp task
+            {
+
+#ifdef PRINT_DEBUG_INFO_
+                cout << "\n(" << myRank << ") Waitall= " << endl;
+                fflush(stdout);
+#endif
+#ifdef DEBUG_HANG_
+                cout << "\n(" << myRank << ") Waitall " << endl;
+                fflush(stdout);
+#endif
+                //return;
+
+                MPI_Waitall(MessageIndex, &SRequest[0], &SStatus[0]);
+
+                // MPI_Buffer_attach(&Buffer, BufferSize); //Attach the Buffer
+                if (BufferSize > 0)
+                {
+                    MPI_Buffer_detach(&Buffer, &BufferSize); // Detach the Buffer
+                    free(Buffer);                            // Free the memory that was allocated
+                }
+            }
+
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << ")End of function to compute matching: " << endl;
+            fflush(stdout);
+            cout << "\n(" << myRank << ")myCardinality: " << myCard << endl;
+            fflush(stdout);
+            cout << "\n(" << myRank << ")Matching took " << finishTime - startTime << "seconds" << endl;
+            fflush(stdout);
+            cout << "\n(" << myRank << ")** Getting out of the matching function **" << endl;
+            fflush(stdout);
+#endif
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << ") Number of Ghost edges = " << numGhostEdges;
+            cout << "\n(" << myRank << ") Total number of potential message X 2 = " << numGhostEdges * 2;
+            cout << "\n(" << myRank << ") Number messages bundled = " << NumMessagesBundled;
+            cout << "\n(" << myRank << ") Total Individual Messages sent = " << msgInd;
+            if (msgInd > 0)
+            {
+                cout << "\n(" << myRank << ") Percentage of messages bundled = " << ((double)NumMessagesBundled / (double)(msgInd)) * 100.0 << "% \n";
+            }
+            fflush(stdout);
+#endif
+
+#pragma omp task
+            {
+                *msgActualSent = msgActual;
+                *msgIndSent = msgInd;
+                if (msgInd > 0)
+                {
+                    *msgPercent = ((double)NumMessagesBundled / (double)(msgInd)) * 100.0;
+                }
+                else
+                {
+                    *msgPercent = 0;
+                }
+            }
+
+#ifdef DEBUG_HANG_
+            if (myRank == 0)
+                cout << "\n(" << myRank << ") Done" << endl;
+            fflush(stdout);
+#endif
+        }
+    }
+}

amgprec/impl/aggregator/computeCandidateMate.cpp

@@ -0,0 +1,73 @@
+#include "MatchBoxPC.h"
+
+/**
+ * Execute the research fr the Candidate Mate without controlling if the vertices are already matched.
+ * Returns the vertices with the highest weight
+ * @param adj1
+ * @param adj2
+ * @param verLocInd
+ * @param edgeLocWeight
+ * @return
+ */
+MilanLongInt firstComputeCandidateMate(MilanLongInt adj1,
+                                       MilanLongInt adj2,
+                                       MilanLongInt *verLocInd,
+                                       MilanReal *edgeLocWeight)
+{
+    MilanInt w = -1;
+    MilanReal heaviestEdgeWt = MilanRealMin; // Assign the smallest Value possible first LDBL_MIN
+    int finalK;
+    for (int k = adj1; k < adj2; k++) {
+      if ((edgeLocWeight[k] > heaviestEdgeWt) ||
+	  ((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k])))     {
+	heaviestEdgeWt = edgeLocWeight[k];
+	w = verLocInd[k];
+	finalK = k;
+      }
+    } // End of for loop
+    return finalK;
+}
+
+/**
+ * //TODO documentation
+ * @param adj1
+ * @param adj2
+ * @param edgeLocWeight
+ * @param k
+ * @param verLocInd
+ * @param StartIndex
+ * @param EndIndex
+ * @param GMate
+ * @param Mate
+ * @param Ghost2LocalMap
+ * @return
+ */
+MilanLongInt computeCandidateMate(MilanLongInt adj1,
+                                  MilanLongInt adj2,
+                                  MilanReal *edgeLocWeight,
+                                  MilanLongInt k,
+                                  MilanLongInt *verLocInd,
+                                  MilanLongInt StartIndex,
+                                  MilanLongInt EndIndex,
+                                  vector<MilanLongInt> &GMate,
+                                  MilanLongInt *Mate,
+                                  map<MilanLongInt, MilanLongInt> &Ghost2LocalMap)
+{
+    // Start: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
+
+    MilanInt w = -1;
+    MilanReal heaviestEdgeWt = MilanRealMin; // Assign the smallest Value possible first LDBL_MIN
+    for (k = adj1; k < adj2; k++)   {
+      if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap))
+	continue;
+      
+      if ((edgeLocWeight[k] > heaviestEdgeWt) ||
+	  ((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k])))     {
+	heaviestEdgeWt = edgeLocWeight[k];
+	w = verLocInd[k];
+      }
+    } // End of for loop
+      //  End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
+    
+    return w;
+}

amgprec/impl/aggregator/dataStrStaticQueue.h

@@ -80,9 +80,11 @@ class staticQueue
 		MilanLongInt squeueTail;
 		MilanLongInt NumNodes;
 
+		//FIXME I had to comment this piece of code in order to make everything work.
+		//		why?
 		//Prevent Assignment and Pass by Value:
-		staticQueue(const staticQueue& src);
-		staticQueue& operator=(const staticQueue& rhs);
+		//staticQueue(const staticQueue& src);
+		//staticQueue& operator=(const staticQueue& rhs);
 
 	public:
 		//Constructors and Destructors

amgprec/impl/aggregator/extractUChunk.cpp

@@ -0,0 +1,31 @@
+#include "MatchBoxPC.h"
+
+void extractUChunk(
+    vector<MilanLongInt> &UChunkBeingProcessed,
+    vector<MilanLongInt> &U,
+    vector<MilanLongInt> &privateU)
+{
+
+    UChunkBeingProcessed.clear();
+#pragma omp critical(U)
+    {
+
+        if (U.empty() && !privateU.empty()) // If U is empty but there are nodes in private U
+        {
+            while (!privateU.empty())
+                UChunkBeingProcessed.push_back(privateU.back());
+            privateU.pop_back();
+        }
+        else
+        {
+            for (int i = 0; i < UCHUNK; i++)
+            { // Pop the new nodes
+                if (U.empty())
+                    break;
+                UChunkBeingProcessed.push_back(U.back());
+                U.pop_back();
+            }
+        }
+
+    } // End of critical U // End of critical U
+}

amgprec/impl/aggregator/findOwnerOfGhost.cpp

@@ -0,0 +1,29 @@
+#include "MatchBoxPC.h"
+
+/// Find the owner of a ghost node:
+MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
+                          MilanInt myRank, MilanInt numProcs)
+{
+
+  MilanLongInt mStartInd = mVerDistance[myRank];
+  MilanInt Start = 0;
+  MilanInt End = numProcs;
+  MilanInt Current = 0;
+
+  while (Start <= End)
+  {
+    Current = (End + Start) / 2;
+    // CASE-1:
+    if (mVerDistance[Current] == vtxIndex) return Current;
+    else // CASE 2:
+      if (mVerDistance[Current] > vtxIndex)
+        End = Current - 1;
+      else // CASE 3:
+        Start = Current + 1;
+  } // End of While()
+
+ if (mVerDistance[Current] > vtxIndex)
+      return (Current - 1);
+
+  return Current;
+} // End of findOwnerOfGhost()

amgprec/impl/aggregator/initialize.cpp

@@ -0,0 +1,304 @@
+#include "MatchBoxPC.h"
+
+void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
+                MilanLongInt StartIndex, MilanLongInt EndIndex,
+                MilanLongInt *numGhostEdges,
+                MilanLongInt *numGhostVertices,
+                MilanLongInt *S,
+                MilanLongInt *verLocInd,
+                MilanLongInt *verLocPtr,
+                map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+                vector<MilanLongInt> &Counter,
+                vector<MilanLongInt> &verGhostPtr,
+                vector<MilanLongInt> &verGhostInd,
+                vector<MilanLongInt> &tempCounter,
+                vector<MilanLongInt> &GMate,
+                vector<MilanLongInt> &Message,
+                vector<MilanLongInt> &QLocalVtx,
+                vector<MilanLongInt> &QGhostVtx,
+                vector<MilanLongInt> &QMsgType,
+                vector<MilanInt> &QOwner,
+                MilanLongInt *&candidateMate,
+                vector<MilanLongInt> &U,
+                vector<MilanLongInt> &privateU,
+                vector<MilanLongInt> &privateQLocalVtx,
+                vector<MilanLongInt> &privateQGhostVtx,
+                vector<MilanLongInt> &privateQMsgType,
+                vector<MilanInt> &privateQOwner)
+{
+
+    MilanLongInt insertMe = 0;
+    MilanLongInt adj1, adj2;
+    int i, v, k, w;
+    // index that starts with zero to |Vg|  - 1
+    map<MilanLongInt, MilanLongInt>::iterator storedAlready;
+
+#pragma omp parallel private(insertMe, k, w, v, adj1, adj2) firstprivate(StartIndex, EndIndex) default(shared) num_threads(NUM_THREAD)
+    {
+
+#pragma omp single
+        {
+
+#ifdef TIME_TRACKER
+            double Ghost2LocalInitialization = MPI_Wtime();
+#endif
+
+            /*
+             * OMP Ghost2LocalInitialization
+             * This loop analyzes all the edges and when finds a ghost edge
+             * puts it in the Ghost2LocalMap.
+             * A critical region is needed when inserting data in the map.
+             *
+             * Despite the critical region it is still productive to
+             * parallelize this cycle because the critical region is exeuted
+             * only when a ghost edge is found and ghost edges are a minority,
+             * circa 3.5% during the tests.
+             */
+#pragma omp task depend(out \
+                        : *numGhostEdges, Counter, Ghost2LocalMap, insertMe, storedAlready, *numGhostVertices)
+            {
+#pragma omp taskloop num_tasks(NUM_THREAD) reduction(+ \
+                                                     : numGhostEdges[:1])
+                for (i = 0; i < NLEdge; i++)
+                { // O(m) - Each edge stored twice
+                    insertMe = verLocInd[i];
+                    if ((insertMe < StartIndex) || (insertMe > EndIndex))
+                    { // Find a ghost
+                        (*numGhostEdges)++;
+#pragma omp critical
+                        {
+                            storedAlready = Ghost2LocalMap.find(insertMe);
+                            if (storedAlready != Ghost2LocalMap.end())
+                            {                                     // Has already been added
+                                Counter[storedAlready->second]++; // Increment the counter
+                            }
+                            else
+                            {                                                 // Insert an entry for the ghost:
+                                Ghost2LocalMap[insertMe] = *numGhostVertices; // Add a map entry
+                                Counter.push_back(1);                         // Initialize the counter
+                                (*numGhostVertices)++;                        // Increment the number of ghost vertices
+                            }                                                 // End of else()
+                        }
+                    } // End of if ( (insertMe < StartIndex) || (insertMe > EndIndex) )
+                }     // End of for(ghost vertices)
+            }         // end of task depend
+
+            // *numGhostEdges = atomicNumGhostEdges;
+#ifdef TIME_TRACKER
+            Ghost2LocalInitialization = MPI_Wtime() - Ghost2LocalInitialization;
+            fprintf(stderr, "Ghost2LocalInitialization time: %f\n", Ghost2LocalInitialization);
+#endif
+
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << ")NGhosts:" << *numGhostVertices << " GhostEdges: " << *numGhostEdges;
+            if (!Ghost2LocalMap.empty())
+            {
+                cout << "\n(" << myRank << ")Final Map : on process ";
+                cout << "\n(" << myRank << ")Key \t Value \t Counter \n";
+                fflush(stdout);
+                storedAlready = Ghost2LocalMap.begin();
+                do
+                {
+                    cout << storedAlready->second << " - " << storedAlready->first << " : " << Counter[storedAlready->second] << endl;
+                    fflush(stdout);
+                    storedAlready++;
+                } while (storedAlready != Ghost2LocalMap.end());
+            }
+#endif
+
+#pragma omp task depend(out                                                       \
+                        : verGhostPtr, tempCounter, verGhostInd, GMate) depend(in \
+                                                                               : *numGhostVertices, *numGhostEdges)
+            {
+
+                // Initialize adjacency Lists for Ghost Vertices:
+                try
+                {
+                    verGhostPtr.reserve(*numGhostVertices + 1); // Pointer Vector
+                    tempCounter.reserve(*numGhostVertices);     // Pointer Vector
+                    verGhostInd.reserve(*numGhostEdges);        // Index Vector
+                    GMate.reserve(*numGhostVertices);           // Ghost Mate Vector
+                }
+                catch (length_error)
+                {
+                    cout << "Error in function algoDistEdgeApproxDominatingEdgesLinearSearch: \n";
+                    cout << "Not enough memory to allocate the internal variables \n";
+                    exit(1);
+                }
+                // Initialize the Vectors:
+                verGhostPtr.resize(*numGhostVertices + 1, 0); // Pointer Vector
+                tempCounter.resize(*numGhostVertices, 0);     // Temporary Counter
+                verGhostInd.resize(*numGhostEdges, -1);       // Index Vector
+                GMate.resize(*numGhostVertices, -1);          // Temporary Counter
+                verGhostPtr[0] = 0;                           // The first value
+#ifdef PRINT_DEBUG_INFO_
+                cout << "\n(" << myRank << ")Ghost Vertex Pointer: ";
+                fflush(stdout);
+#endif
+
+            } // End of task
+
+#pragma omp task depend(out                      \
+                        : verGhostPtr) depend(in \
+                                              : Counter, *numGhostVertices)
+            {
+
+#ifdef TIME_TRACKER
+                double verGhostPtrInitialization = MPI_Wtime();
+#endif
+                for (i = 0; i < *numGhostVertices; i++)
+                { // O(|Ghost Vertices|)
+                    verGhostPtr[i + 1] = verGhostPtr[i] + Counter[i];
+#ifdef PRINT_DEBUG_INFO_
+                    cout << verGhostPtr[i] << "\t";
+                    fflush(stdout);
+#endif
+                }
+
+#ifdef TIME_TRACKER
+                verGhostPtrInitialization = MPI_Wtime() - verGhostPtrInitialization;
+                fprintf(stderr, "verGhostPtrInitialization time: %f\n", verGhostPtrInitialization);
+#endif
+            } // End of task
+
+#ifdef PRINT_DEBUG_INFO_
+            if (*numGhostVertices > 0)
+                cout << verGhostPtr[*numGhostVertices] << "\n";
+            fflush(stdout);
+#endif
+
+#ifdef TIME_TRACKER
+            double verGhostIndInitialization = MPI_Wtime();
+#endif
+
+            /*
+             * OMP verGhostIndInitialization
+             *
+             * In this cycle the verGhostInd is initialized
+             * with the datas related to ghost edges.
+             * The check to see if a node is a ghost node is
+             * executed in paralle and when a ghost node
+             * is found a critical region is started.
+             *
+             * Despite the critical region it's still useful to
+             * parallelize the for cause the ghost nodes
+             * are a minority hence the critical region is executed
+             * few times, circa 3.5% of the times in the tests.
+             */
+#pragma omp task depend(in                                                               \
+                        : insertMe, Ghost2LocalMap, tempCounter, verGhostPtr) depend(out \
+                                                                                     : verGhostInd)
+            {
+#pragma omp taskloop num_tasks(NUM_THREAD)
+                for (v = 0; v < NLVer; v++)
+                {
+                    adj1 = verLocPtr[v]; // Vertex Pointer
+                    adj2 = verLocPtr[v + 1];
+                    for (k = adj1; k < adj2; k++)
+                    {
+                        w = verLocInd[k]; // Get the adjacent vertex
+                        if ((w < StartIndex) || (w > EndIndex))
+                        { // Find a ghost
+#pragma omp critical
+                            {
+                                insertMe = verGhostPtr[Ghost2LocalMap[w]] + tempCounter[Ghost2LocalMap[w]]; // Where to insert
+                                tempCounter[Ghost2LocalMap[w]]++;                                           // Increment the counter
+                            }
+                            verGhostInd[insertMe] = v + StartIndex; // Add the adjacency
+                        }                                           // End of if((w < StartIndex) || (w > EndIndex))
+                    }                                               // End of for(k)
+                }                                                   // End of for (v)
+            }                                                       // end of tasklopp
+
+#ifdef TIME_TRACKER
+            verGhostIndInitialization = MPI_Wtime() - verGhostIndInitialization;
+            fprintf(stderr, "verGhostIndInitialization time: %f\n", verGhostIndInitialization);
+#endif
+
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << ")Ghost Vertex Index: ";
+            for (v = 0; v < *numGhostEdges; v++)
+                cout << verGhostInd[v] << "\t";
+            cout << endl;
+            fflush(stdout);
+#endif
+
+#pragma omp task depend(in                           \
+                        : *numGhostEdges) depend(out \
+                                                 : QLocalVtx, QGhostVtx, QMsgType, QOwner)
+            {
+                try
+                {
+                    QLocalVtx.reserve(*numGhostEdges); // Local Vertex
+                    QGhostVtx.reserve(*numGhostEdges); // Ghost Vertex
+                    QMsgType.reserve(*numGhostEdges);  // Message Type (Request/Failure)
+                    QOwner.reserve(*numGhostEdges);    // Owner of the ghost: COmpute once and use later
+                }
+                catch (length_error)
+                {
+                    cout << "Error in function algoDistEdgeApproxDominatingEdgesMessageBundling: \n";
+                    cout << "Not enough memory to allocate the internal variables \n";
+                    exit(1);
+                }
+            } // end of task
+
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << ")Allocating CandidateMate.. ";
+            fflush(stdout);
+#endif
+
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << "=========================************===============================" << endl;
+            fflush(stdout);
+            fflush(stdout);
+#endif
+
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << ") Setup Time :" << *ph0_time << endl;
+            fflush(stdout);
+            fflush(stdout);
+#endif
+
+#ifdef DEBUG_HANG_
+            if (myRank == 0)
+                cout << "\n(" << myRank << ") Setup Time :" << *ph0_time << endl;
+            fflush(stdout);
+#endif
+
+#pragma omp task depend(in                              \
+                        : *numGhostVertices) depend(out \
+                                                    : candidateMate, S, U, privateU, privateQLocalVtx, privateQGhostVtx, privateQMsgType, privateQOwner)
+            {
+
+                // Allocate Data Structures:
+                /*
+                 * candidateMate was a vector and has been replaced with an array
+                 * there is no point in using the vector (or maybe there is (???))
+                 * so I replaced it with an array wich is slightly faster
+                 */
+                candidateMate = new MilanLongInt[NLVer + (*numGhostVertices)];
+
+                *S = (*numGhostVertices); // Initialize S with number of Ghost Vertices
+
+                /*
+                 * Create the Queue Data Structure for the Dominating Set
+                 *
+                 * I had to declare the staticuQueue U before the parallel region
+                 * to have it in the correct scope. Since we can't change the dimension
+                 * of a staticQueue I had to destroy the previous object and instantiate
+                 * a new one of the correct size.
+                 */
+                //new (&U) staticQueue(NLVer + (*numGhostVertices));
+                U.reserve(NLVer + (*numGhostVertices));
+
+                // Initialize the private vectors                
+                privateQLocalVtx.reserve(*numGhostVertices);
+                privateQGhostVtx.reserve(*numGhostVertices);
+                privateQMsgType.reserve(*numGhostVertices);
+                privateQOwner.reserve(*numGhostVertices);
+                privateU.reserve(*numGhostVertices);
+            } // end of task
+
+        } // End of single region
+    }     // End of parallel region
+}

amgprec/impl/aggregator/isAlreadyMatched.cpp

@@ -0,0 +1,46 @@
+#include "MatchBoxPC.h"
+
+/**
+ * //TODO documentation
+ * @param k
+ * @param verLocInd
+ * @param StartIndex
+ * @param EndIndex
+ * @param GMate
+ * @param Mate
+ * @param Ghost2LocalMap
+ * @return
+ */
+bool isAlreadyMatched(MilanLongInt node,
+                      MilanLongInt StartIndex,
+                      MilanLongInt EndIndex,
+                      vector<MilanLongInt> &GMate,
+                      MilanLongInt *Mate,
+                      map<MilanLongInt, MilanLongInt> &Ghost2LocalMap)
+{
+
+    /*
+#pragma omp critical(Mate)
+    {
+        if ((node < StartIndex) || (node > EndIndex)) { //Is it a ghost vertex?
+            result = GMate[Ghost2LocalMap[node]] >= 0;// Already matched
+        } else { //A local vertex
+            result = (Mate[node - StartIndex] >= 0); // Already matched
+        }
+
+    }
+    */
+    MilanLongInt val;
+    if ((node < StartIndex) || (node > EndIndex)) // if ghost vertex
+    { 
+#pragma omp atomic read
+        val = GMate[Ghost2LocalMap[node]];
+        return val >= 0; // Already matched
+    }
+
+    // If not ghost vertex
+#pragma omp atomic read
+    val = Mate[node - StartIndex];
+
+    return val >= 0; // Already matched
+}

amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp

@@ -0,0 +1,27 @@
+#include "MatchBoxPC.h"
+
+void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer,
+                                              MilanLongInt *verLocPtr,
+                                              MilanLongInt *verLocInd,
+                                              MilanInt myRank,
+                                              MilanReal *edgeLocWeight,
+                                              MilanLongInt *candidateMate)
+{
+
+    MilanLongInt v = -1;
+
+#pragma omp parallel private(v) default(shared) num_threads(NUM_THREAD)
+    {
+
+#pragma omp for schedule(static)
+        for (v = 0; v < NLVer; v++) {
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << ")Processing: " << v + StartIndex << endl;
+            fflush(stdout);
+#endif
+            // Start: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
+            candidateMate[v] = firstComputeCandidateMate(verLocPtr[v], verLocPtr[v + 1], verLocInd, edgeLocWeight);
+            // End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
+        }
+    }
+}

amgprec/impl/aggregator/processCrossEdge.cpp

@@ -0,0 +1,24 @@
+#include "MatchBoxPC.h"
+
+void PROCESS_CROSS_EDGE(MilanLongInt *edge,
+                        MilanLongInt *S)
+{
+    // Start: PARALLEL_PROCESS_CROSS_EDGE_B
+    MilanLongInt captureCounter;
+
+#pragma omp atomic capture
+    captureCounter = --(*edge); // Decrement
+
+    //assert(captureCounter >= 0);
+
+    if (captureCounter == 0)
+#pragma omp atomic
+        (*S)--; // Decrement S
+
+#ifdef PRINT_DEBUG_INFO_
+    cout << "\n(" << myRank << ")Decrementing S: Ghost vertex " << edge << " has received all its messages";
+    fflush(stdout);
+#endif
+
+    // End: PARALLEL_PROCESS_CROSS_EDGE_B
+}

amgprec/impl/aggregator/processExposedVertex.cpp

@@ -0,0 +1,195 @@
+#include "MatchBoxPC.h"
+
+void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer,
+                                       MilanLongInt *candidateMate,
+                                       MilanLongInt *verLocInd,
+                                       MilanLongInt *verLocPtr,
+                                       MilanLongInt StartIndex,
+                                       MilanLongInt EndIndex,
+                                       MilanLongInt *Mate,
+                                       vector<MilanLongInt> &GMate,
+                                       map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+                                       MilanReal *edgeLocWeight,
+                                       MilanLongInt *myCard,
+                                       MilanLongInt *msgInd,
+                                       MilanLongInt *NumMessagesBundled,
+                                       MilanLongInt *S,
+                                       MilanLongInt *verDistance,
+                                       MilanLongInt *PCounter,
+                                       vector<MilanLongInt> &Counter,
+                                       MilanInt myRank,
+                                       MilanInt numProcs,
+                                       vector<MilanLongInt> &U,
+                                       vector<MilanLongInt> &privateU,
+                                       vector<MilanLongInt> &QLocalVtx,
+                                       vector<MilanLongInt> &QGhostVtx,
+                                       vector<MilanLongInt> &QMsgType,
+                                       vector<MilanInt> &QOwner,
+                                       vector<MilanLongInt> &privateQLocalVtx,
+                                       vector<MilanLongInt> &privateQGhostVtx,
+                                       vector<MilanLongInt> &privateQMsgType,
+                                       vector<MilanInt> &privateQOwner)
+{ 
+
+    MilanLongInt v = -1, k = -1, w = -1, adj11 = 0, adj12 = 0, k1 = 0;
+    MilanInt ghostOwner = 0, option, igw;
+
+#pragma omp parallel private(option, k, w, v, k1, adj11, adj12, ghostOwner)    \
+    firstprivate(privateU, StartIndex, EndIndex, privateQLocalVtx, privateQGhostVtx, privateQMsgType, privateQOwner) \
+     default(shared)   num_threads(NUM_THREAD)
+
+    {
+#pragma omp for reduction(+                             \
+                          : PCounter[:numProcs], myCard \
+                          [:1], msgInd                  \
+                          [:1], NumMessagesBundled      \
+                          [:1]) \
+        schedule(static)
+        for (v = 0; v < NLVer; v++) {
+            option = -1;
+            // Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
+            k = candidateMate[v];
+            candidateMate[v] = verLocInd[k];
+            w = candidateMate[v];
+
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << ")Processing: " << v + StartIndex << endl;
+            fflush(stdout);
+#endif
+
+#ifdef PRINT_DEBUG_INFO_
+            cout << "\n(" << myRank << ")" << v + StartIndex << " Points to: " << w;
+            fflush(stdout);
+#endif
+            // If found a dominating edge:
+            if (w >= 0)
+            {
+
+#pragma omp critical(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
+			  
+#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
+	      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);
+		  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);
+                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
+}

amgprec/impl/aggregator/processMatchedVertices.cpp

@@ -0,0 +1,294 @@
+#include "MatchBoxPC.h"
+
+void processMatchedVertices(
+    MilanLongInt NLVer,
+    vector<MilanLongInt> &UChunkBeingProcessed,
+    vector<MilanLongInt> &U,
+    vector<MilanLongInt> &privateU,
+    MilanLongInt StartIndex,
+    MilanLongInt EndIndex,
+    MilanLongInt *myCard,
+    MilanLongInt *msgInd,
+    MilanLongInt *NumMessagesBundled,
+    MilanLongInt *SPtr,
+    MilanLongInt *verLocPtr,
+    MilanLongInt *verLocInd,
+    MilanLongInt *verDistance,
+    MilanLongInt *PCounter,
+    vector<MilanLongInt> &Counter,
+    MilanInt myRank,
+    MilanInt numProcs,
+    MilanLongInt *candidateMate,
+    vector<MilanLongInt> &GMate,
+    MilanLongInt *Mate,
+    map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+    MilanReal *edgeLocWeight,
+    vector<MilanLongInt> &QLocalVtx,
+    vector<MilanLongInt> &QGhostVtx,
+    vector<MilanLongInt> &QMsgType,
+    vector<MilanInt> &QOwner,
+    vector<MilanLongInt> &privateQLocalVtx,
+    vector<MilanLongInt> &privateQGhostVtx,
+    vector<MilanLongInt> &privateQMsgType,
+    vector<MilanInt> &privateQOwner)
+{
+
+    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
+		    {
+		      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);
+#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);
+		    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);
+			
+			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
+}

amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp

@@ -0,0 +1,308 @@
+#include "MatchBoxPC.h"
+//#define DEBUG_HANG_
+void processMatchedVerticesAndSendMessages(
+					   MilanLongInt NLVer,
+					   vector<MilanLongInt> &UChunkBeingProcessed,
+					   vector<MilanLongInt> &U,
+					   vector<MilanLongInt> &privateU,
+					   MilanLongInt StartIndex,
+					   MilanLongInt EndIndex,
+					   MilanLongInt *myCard,
+					   MilanLongInt *msgInd,
+					   MilanLongInt *NumMessagesBundled,
+					   MilanLongInt *SPtr,
+					   MilanLongInt *verLocPtr,
+					   MilanLongInt *verLocInd,
+					   MilanLongInt *verDistance,
+					   MilanLongInt *PCounter,
+					   vector<MilanLongInt> &Counter,
+					   MilanInt myRank,
+					   MilanInt numProcs,
+					   MilanLongInt *candidateMate,
+					   vector<MilanLongInt> &GMate,
+					   MilanLongInt *Mate,
+					   map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+					   MilanReal *edgeLocWeight,
+					   vector<MilanLongInt> &QLocalVtx,
+					   vector<MilanLongInt> &QGhostVtx,
+					   vector<MilanLongInt> &QMsgType,
+					   vector<MilanInt> &QOwner,
+					   vector<MilanLongInt> &privateQLocalVtx,
+					   vector<MilanLongInt> &privateQGhostVtx,
+					   vector<MilanLongInt> &privateQMsgType,
+					   vector<MilanInt> &privateQOwner,
+					   MPI_Comm comm,
+					   MilanLongInt *msgActual,
+					   vector<MilanLongInt> &Message)
+{
+
+    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
+		    {
+		      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);
+#endif
+			// If found a dominating edge:
+			if (w >= 0)  {
+			  
+			  if ((w < StartIndex) || (w > EndIndex))  { // A ghost
+#ifdef PRINT_DEBUG_INFO_
+			    cout << "\n(" << myRank << ")Sending a request message:";
+			    cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
+#endif
+			    option = 2;
+			    
+			    if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
+			      option = 1;
+			      Mate[v - StartIndex] = w;     // v is a local vertex
+			      GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
+			      
+			    } // End of if CandidateMate[w] = v
+			  }     // End of if a Ghost Vertex
+			  else   { // w is a local vertex
+			    if (candidateMate[w - StartIndex] == v)  {
+			      option = 3;
+			      Mate[v - StartIndex] = w; // v is a local vertex
+			      Mate[w - StartIndex] = v; // w is a local vertex
+			      
+#ifdef PRINT_DEBUG_INFO_
+			      cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
+			      fflush(stdout);
+#endif
+			    } // End of if(CandidateMate(w) = v
+			  }     // End of Else
+			}         // End of if(w >=0)
+			else
+			  option = 4; // End of Else: w == -1
+			// End:   PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
+		      } // End of If (candidateMate[v-StartIndex] == u
+		    }     // End of task
+		  }         // mateval < 0
+		}             // End of if ( (v >= StartIndex) && (v <= EndIndex) ) //If Local Vertex:
+		else { // Neighbor is a ghost vertex
+		  
+#pragma omp critical
+		  {
+		    if (candidateMate[NLVer + Ghost2LocalMap[v]] == u)
+		      candidateMate[NLVer + Ghost2LocalMap[v]] = -1;
+		    if (v != Mate[u - StartIndex])
+		      option = 5; // u is local
+		  }                   // End of critical
+		}                       // End of Else //A Ghost Vertex
+		
+		switch (option)
+		  {
+		  case -1:
+		    // No things to do
+		    break;
+		  case 1:
+		    // Found a dominating edge, it is a ghost and candidateMate[NLVer + Ghost2LocalMap[w]] == v
+		    privateU.push_back(v);
+		    privateU.push_back(w);
+		    (*myCard)++;
+#ifdef PRINT_DEBUG_INFO_
+		    cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
+		    fflush(stdout);
+#endif
+		    // Decrement the counter:
+		    PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], SPtr);
+		  case 2:
+		    
+		    // Found a dominating edge, it is a ghost
+		    ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
+		    
+		    // Build the Message Packet:
+		    // Message[0] = v;       // LOCAL
+		    // Message[1] = w;       // GHOST
+		    // Message[2] = REQUEST; // TYPE
+		    // Send a Request (Asynchronous)
+		    // MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
+		    
+		    (*msgActual)++;
+		    (*msgInd)++;
+		    
+		    privateQLocalVtx.push_back(v);
+		    privateQGhostVtx.push_back(w);
+		    privateQMsgType.push_back(REQUEST);
+		    privateQOwner.push_back(ghostOwner);
+		    break;
+		  case 3:
+		    privateU.push_back(v);
+		    privateU.push_back(w);
+		    (*myCard)++;
+		    break;
+		  case 4:
+		    // Could not find a dominating vertex
+		    adj11 = verLocPtr[v - StartIndex];
+		    adj12 = verLocPtr[v - StartIndex + 1];
+		    for (k1 = adj11; k1 < adj12; k1++) {
+		      w = verLocInd[k1];
+		      if ((w < StartIndex) || (w > EndIndex))  { // A ghost
+			
+#ifdef PRINT_DEBUG_INFO_
+			cout << "\n(" << myRank << ")Sending a failure message: ";
+			cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
+			fflush(stdout);
+#endif
+			
+			ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
+			
+			// Build the Message Packet:
+			// Message[0] = v;       // LOCAL
+			// Message[1] = w;       // GHOST
+			// Message[2] = FAILURE; // TYPE
+			// Send a Request (Asynchronous)
+			// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
+			
+			(*msgActual)++;
+			(*msgInd)++;
+			
+			privateQLocalVtx.push_back(v);
+			privateQGhostVtx.push_back(w);
+			privateQMsgType.push_back(FAILURE);
+			privateQOwner.push_back(ghostOwner);
+			
+		      } // End of if(GHOST)
+		    }     // End of for loop
+		    break;
+		  case 5:
+		  default:
+		    
+#ifdef PRINT_DEBUG_INFO_
+		    cout << "\n(" << myRank << ")Sending a success message: ";
+		    cout << "\n(" << myRank << ")Ghost is " << v << " Owner is: " << findOwnerOfGhost(v, verDistance, myRank, numProcs) << "\n";
+		    fflush(stdout);
+#endif
+		    
+		    ghostOwner = findOwnerOfGhost(v, verDistance, myRank, numProcs);
+		    
+		    // Build the Message Packet:
+		    // Message[0] = u;       // LOCAL
+		    // Message[1] = v;       // GHOST
+		    // Message[2] = SUCCESS; // TYPE
+		    // Send a Request (Asynchronous)
+		    // MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
+		    
+		    (*msgActual)++;
+		    (*msgInd)++;
+		    
+		    privateQLocalVtx.push_back(u);
+		    privateQGhostVtx.push_back(v);
+		    privateQMsgType.push_back(SUCCESS);
+		    privateQOwner.push_back(ghostOwner);
+		    
+		    break;
+		  } // End of switch
+	      }     // End of inner for
+	    }
+	  } // End of outer for
+	  
+	  queuesTransfer(U, privateU, QLocalVtx,
+			 QGhostVtx,
+			 QMsgType, QOwner, privateQLocalVtx,
+			 privateQGhostVtx,
+			 privateQMsgType,
+			 privateQOwner);
+	  
+        } // End of while ( !U.empty() )
+	
+#ifdef COUNT_LOCAL_VERTEX
+        printf("Count local vertexes: %ld for thread %d of processor %d\n",
+               localVertices,
+               omp_get_thread_num(),
+               myRank);
+	
+#endif
+    } // End of parallel region
+    
+    // Send the messages
+#ifdef DEBUG_HANG_
+    cout << myRank<<" Sending: "<<QOwner.size()-initialSize<<" messages" <<endl;
+#endif
+    for (int i = initialSize; i < QOwner.size(); i++)   {
+      
+      Message[0] = QLocalVtx[i];
+      Message[1] = QGhostVtx[i];
+      Message[2] = QMsgType[i];
+      ghostOwner = QOwner[i];
+      
+      //MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
+      //cout << myRank<<" Sending to "<<ghostOwner<<endl;
+      MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
+    }
+#ifdef DEBUG_HANG_
+    cout << myRank<<" Done sending messages"<<endl;
+#endif
+}

amgprec/impl/aggregator/processMessages.cpp

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

amgprec/impl/aggregator/queueTransfer.cpp

@@ -0,0 +1,36 @@
+#include "MatchBoxPC.h"
+
+void queuesTransfer(vector<MilanLongInt> &U,
+                    vector<MilanLongInt> &privateU,
+                    vector<MilanLongInt> &QLocalVtx,
+                    vector<MilanLongInt> &QGhostVtx,
+                    vector<MilanLongInt> &QMsgType,
+                    vector<MilanInt> &QOwner,
+                    vector<MilanLongInt> &privateQLocalVtx,
+                    vector<MilanLongInt> &privateQGhostVtx,
+                    vector<MilanLongInt> &privateQMsgType,
+                    vector<MilanInt> &privateQOwner)
+{
+
+#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();
+
+}

amgprec/impl/aggregator/sendBundledMessages.cpp

@@ -0,0 +1,209 @@
+#include "MatchBoxPC.h"
+
+void sendBundledMessages(MilanLongInt *numGhostEdges,
+                                MilanInt *BufferSize,
+                                MilanLongInt *Buffer,
+                                vector<MilanLongInt> &PCumulative,
+                                vector<MilanLongInt> &PMessageBundle,
+                                vector<MilanLongInt> &PSizeInfoMessages,
+                                MilanLongInt *PCounter,
+                                MilanLongInt NumMessagesBundled,
+                                MilanLongInt *msgActual,
+                                MilanLongInt *msgInd,
+                                MilanInt numProcs,
+                                MilanInt myRank,
+                                MPI_Comm comm,
+                                vector<MilanLongInt> &QLocalVtx,
+                                vector<MilanLongInt> &QGhostVtx,
+                                vector<MilanLongInt> &QMsgType,
+                                vector<MilanInt> &QOwner,
+                                vector<MPI_Request> &SRequest,
+                                vector<MPI_Status> &SStatus)
+{
+
+    MilanLongInt myIndex = 0, numMessagesToSend;
+    MilanInt i = 0, OneMessageSize = 0;
+
+#ifdef DEBUG_HANG_
+    if (myRank == 0)
+        cout << "\n(" << myRank << ") Send Bundles" << endl;
+    fflush(stdout);
+#endif
+
+#pragma omp parallel private(i) default(shared) num_threads(NUM_THREAD)
+    {
+#pragma omp master
+        {
+// Data structures for Bundled Messages:
+#pragma omp task depend(inout                                                       \
+                        : PCumulative, PMessageBundle, PSizeInfoMessages) depend(in \
+                                                                                 : NumMessagesBundled, numProcs)
+            {
+	      try {
+                PMessageBundle.reserve(NumMessagesBundled * 3); // Three integers per message
+		PCumulative.reserve(numProcs + 1);                          // Similar to Row Pointer vector in CSR data structure
+		PSizeInfoMessages.reserve(numProcs * 3);                    // Buffer to hold the Size info message packets
+	      }
+	      catch (length_error)
+		{
+		  cout << "Error in function algoDistEdgeApproxDominatingEdgesMessageBundling: \n";
+		  cout << "Not enough memory to allocate the internal variables \n";
+		  exit(1);
+		}
+	      PMessageBundle.resize(NumMessagesBundled * 3, -1); // Initialize
+	      PCumulative.resize(numProcs + 1, 0);               // Only initialize the counter variable
+	      PSizeInfoMessages.resize(numProcs * 3, 0);
+	    }
+
+#pragma omp task depend(inout                    \
+                        : PCumulative) depend(in		\
+                                              : PCounter)
+	    {
+	      for (i = 0; i < numProcs; i++)
+		PCumulative[i + 1] = PCumulative[i] + PCounter[i];
+	    }
+	    
+#pragma omp task depend(inout \
+                        : PCounter)
+	    {
+	      // Reuse PCounter to keep track of how many messages were inserted:
+	      for (MilanInt i = 0; i < numProcs; i++) // Changed by Fabio to be an integer, addresses needs to be integers!
+		PCounter[i] = 0;
+	    }
+
+// Build the Message Bundle packet:
+#pragma omp task depend(in                                                                                          \
+                        : PCounter, QLocalVtx, QGhostVtx, QMsgType, QOwner, PMessageBundle, PCumulative) depend(out \
+                                                                                                                : myIndex, PMessageBundle, PCounter)
+{
+  for (i = 0; i < NumMessagesBundled; i++)   {
+    myIndex = (PCumulative[QOwner[i]] + PCounter[QOwner[i]]) * 3;
+    PMessageBundle[myIndex + 0] = QLocalVtx[i];
+    PMessageBundle[myIndex + 1] = QGhostVtx[i];
+    PMessageBundle[myIndex + 2] = QMsgType[i];
+    PCounter[QOwner[i]]++;
+  }
+ }
+ 
+// Send the Bundled Messages: Use ISend
+#pragma omp task depend(out \
+                        : SRequest, SStatus)
+ {
+   try
+     {
+       SRequest.reserve(numProcs * 2); // At most two messages per processor
+       SStatus.reserve(numProcs * 2);  // At most two messages per processor
+     }
+   catch (length_error)
+     {
+       cout << "Error in function algoDistEdgeApproxDominatingEdgesLinearSearchImmediateSend: \n";
+       cout << "Not enough memory to allocate the internal variables \n";
+       exit(1);
+     }
+ }
+ 
+// Send the Messages
+#pragma omp task depend(inout                                                  \
+                        : SRequest, PSizeInfoMessages, PCumulative) depend(out \
+                                                                           : *msgActual, *msgInd)
+{
+  for (i = 0; i < numProcs; i++)   {                    // Changed by Fabio to be an integer, addresses needs to be integers!
+    if (i == myRank) // Do not send anything to yourself
+      continue;
+    // Send the Message with information about the size of next message:
+    // Build the Message Packet:
+    PSizeInfoMessages[i * 3 + 0] = (PCumulative[i + 1] - PCumulative[i]) * 3; // # of integers in the next message
+    PSizeInfoMessages[i * 3 + 1] = -1;                                        // Dummy packet
+    PSizeInfoMessages[i * 3 + 2] = SIZEINFO;                                  // TYPE
+    // Send a Request (Asynchronous)
+#ifdef PRINT_DEBUG_INFO_
+    cout << "\n(" << myRank << ")Sending bundled message to process " << i << " size: " << PSizeInfoMessages[i * 3 + 0] << endl;
+    fflush(stdout);
+#endif
+    if (PSizeInfoMessages[i * 3 + 0] > 0)
+      { // Send only if it is a nonempty packet
+	MPI_Isend(&PSizeInfoMessages[i * 3 + 0], 3, TypeMap<MilanLongInt>(), i, ComputeTag, comm,
+		  &SRequest[(*msgInd)]);
+	(*msgActual)++;
+	(*msgInd)++;
+	// Now Send the message with the data packet:
+#ifdef PRINT_DEBUG_INFO_
+	cout << "\n(" << myRank << ")SendiFFng Bundle to : " << i << endl;
+	for (k = (PCumulative[i] * 3); k < (PCumulative[i] * 3 + PSizeInfoMessages[i * 3 + 0]); k++)
+	  cout << PMessageBundle[k] << ",";
+	cout << endl;
+	fflush(stdout);
+#endif
+	MPI_Isend(&PMessageBundle[PCumulative[i] * 3], PSizeInfoMessages[i * 3 + 0],
+		  TypeMap<MilanLongInt>(), i, BundleTag, comm, &SRequest[(*msgInd)]);
+	(*msgInd)++;
+      } // End of if size > 0
+  }
+}
+
+#pragma omp task depend(inout \
+                        : PCumulative, QLocalVtx, QGhostVtx, QMsgType, QOwner)
+{
+
+    // Free up temporary memory:
+  PCumulative.clear();
+  QLocalVtx.clear();
+  QGhostVtx.clear();
+  QMsgType.clear();
+  QOwner.clear();
+}
+
+#pragma omp task depend(inout : OneMessageSize, *BufferSize) depend(out : numMessagesToSend) depend(in : *numGhostEdges)
+{
+
+#ifdef PRINT_DEBUG_INFO_
+  cout << "\n(" << myRank << ")Number of Ghost edges = " << *numGhostEdges;
+  cout << "\n(" << myRank << ")Total number of potential message X 2 = " << *numGhostEdges * 2;
+  cout << "\n(" << myRank << ")Number messages already sent in bundles = " << NumMessagesBundled;
+  if (*numGhostEdges > 0)
+    {
+      cout << "\n(" << myRank << ")Percentage of total = " << ((double)NumMessagesBundled / (double)(*numGhostEdges * 2)) * 100.0 << "% \n";
+    }
+  fflush(stdout);
+#endif
+
+  // Allocate memory for MPI Send messages:
+  /* WILL COME BACK HERE - NO NEED TO STORE ALL THIS MEMORY !! */
+  OneMessageSize = 0;
+  MPI_Pack_size(3, TypeMap<MilanLongInt>(), comm, &OneMessageSize); // Size of one message packet
+  // How many messages to send?
+  // Potentially three kinds of messages will be sent/received:
+  // Request, Success, Failure.
+  // But only two will be sent from a given processor.
+  // Substract the number of messages that have already been sent as bundled messages:
+  numMessagesToSend = (*numGhostEdges) * 2 - NumMessagesBundled;
+  *BufferSize = (OneMessageSize + MPI_BSEND_OVERHEAD) * numMessagesToSend;
+}
+
+#pragma omp task depend(out : Buffer) depend(in : *BufferSize)
+ {
+   Buffer = 0;
+#ifdef PRINT_DEBUG_INFO_
+   cout << "\n(" << myRank << ")Size of One Message from PACK= " << OneMessageSize;
+   cout << "\n(" << myRank << ")Size of Message overhead = " << MPI_BSEND_OVERHEAD;
+   cout << "\n(" << myRank << ")Number of Ghost edges = " << *numGhostEdges;
+   cout << "\n(" << myRank << ")Number of remaining message = " << numMessagesToSend;
+   cout << "\n(" << myRank << ")BufferSize = " << (*BufferSize);
+   cout << "\n(" << myRank << ")Attaching Buffer on.. ";
+   fflush(stdout);
+#endif
+   if ((*BufferSize) > 0)
+     {
+       Buffer = (MilanLongInt *)malloc((*BufferSize)); // Allocate memory
+       if (Buffer == 0)
+	 {
+	   cout << "Error in function algoDistEdgeApproxDominatingEdgesLinearSearch: \n";
+	   cout << "Not enough memory to allocate for send buffer on process " << myRank << "\n";
+	   exit(1);
+	 }
+       MPI_Buffer_attach(Buffer, *BufferSize); // Attach the Buffer
+     }
+ }
+}
+}
+}

amgprec/impl/amg_ccprecset.F90

@@ -84,6 +84,7 @@ subroutine amg_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
   use amg_c_diag_solver
   use amg_c_l1_diag_solver
   use amg_c_ilu_solver
+  use amg_c_jac_solver
   use amg_c_id_solver
   use amg_c_gs_solver
   use amg_c_ainv_solver
@@ -308,6 +309,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
   use amg_c_diag_solver
   use amg_c_l1_diag_solver
   use amg_c_ilu_solver
+  use amg_c_jac_solver
   use amg_c_id_solver
   use amg_c_gs_solver
   use amg_c_ainv_solver

amgprec/impl/amg_dcprecset.F90

@@ -84,6 +84,7 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
   use amg_d_diag_solver
   use amg_d_l1_diag_solver
   use amg_d_ilu_solver
+  use amg_d_jac_solver
   use amg_d_id_solver
   use amg_d_gs_solver
   use amg_d_ainv_solver
@@ -314,6 +315,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
   use amg_d_diag_solver
   use amg_d_l1_diag_solver
   use amg_d_ilu_solver
+  use amg_d_jac_solver
   use amg_d_id_solver
   use amg_d_gs_solver
   use amg_d_ainv_solver

amgprec/impl/amg_scprecset.F90

@@ -84,6 +84,7 @@ subroutine amg_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
   use amg_s_diag_solver
   use amg_s_l1_diag_solver
   use amg_s_ilu_solver
+  use amg_s_jac_solver
   use amg_s_id_solver
   use amg_s_gs_solver
   use amg_s_ainv_solver
@@ -308,6 +309,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
   use amg_s_diag_solver
   use amg_s_l1_diag_solver
   use amg_s_ilu_solver
+  use amg_s_jac_solver
   use amg_s_id_solver
   use amg_s_gs_solver
   use amg_s_ainv_solver

amgprec/impl/amg_zcprecset.F90

@@ -84,6 +84,7 @@ subroutine amg_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
   use amg_z_diag_solver
   use amg_z_l1_diag_solver
   use amg_z_ilu_solver
+  use amg_z_jac_solver
   use amg_z_id_solver
   use amg_z_gs_solver
   use amg_z_ainv_solver
@@ -314,6 +315,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
   use amg_z_diag_solver
   use amg_z_l1_diag_solver
   use amg_z_ilu_solver
+  use amg_z_jac_solver
   use amg_z_id_solver
   use amg_z_gs_solver
   use amg_z_ainv_solver

amgprec/impl/level/amg_c_base_onelev_csetc.F90

@@ -46,6 +46,7 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
   use amg_c_as_smoother
   use amg_c_diag_solver
   use amg_c_l1_diag_solver
+  use amg_c_jac_solver
   use amg_c_ilu_solver
   use amg_c_id_solver
   use amg_c_gs_solver
@@ -78,6 +79,8 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
   type(amg_c_as_smoother_type)     ::  amg_c_as_smoother_mold
   type(amg_c_diag_solver_type)     ::  amg_c_diag_solver_mold
   type(amg_c_l1_diag_solver_type)  ::  amg_c_l1_diag_solver_mold
+  type(amg_c_jac_solver_type)      ::  amg_c_jac_solver_mold
+  type(amg_c_l1_jac_solver_type)   ::  amg_c_l1_jac_solver_mold
   type(amg_c_ilu_solver_type)      ::  amg_c_ilu_solver_mold
   type(amg_c_id_solver_type)       ::  amg_c_id_solver_mold
   type(amg_c_gs_solver_type)       ::  amg_c_gs_solver_mold
@@ -188,8 +191,13 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
     case ('DIAG')
       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')
       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)
@@ -243,7 +251,7 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
     end if
 
     select case(val)
-    case('DEC')
+    case('DEC','DECOUPLED')
       allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
     case('SYMDEC')
       allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)

amgprec/impl/level/amg_c_base_onelev_mat_asb.f90

@@ -109,6 +109,8 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   type(psb_cspmat_type)    :: ac, op_restr, op_prol
   integer(psb_ipk_)        :: nzl, inl
   integer(psb_ipk_)        :: debug_level, debug_unit
+  integer(psb_ipk_), save  :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
+  logical, parameter :: do_timings=.false.
 
   name='amg_c_onelev_mat_asb'
   call psb_erractionsave(err_act)
@@ -120,6 +122,12 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  if ((do_timings).and.(idx_matbld==-1))       &
+       & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
+  if ((do_timings).and.(idx_matasb==-1))     &
+       & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
+  if ((do_timings).and.(idx_mapbld==-1))       &
+       & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
 
   call amg_check_def(lv%parms%aggr_prol,'Smoother',&
        &   amg_smooth_prol_,is_legal_ml_aggr_prol)
@@ -139,9 +147,10 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   ! the mapping defined by amg_aggrmap_bld and applying the aggregation
   ! algorithm specified by lv%iprcparm(amg_aggr_prol_)
   !
+  if (do_timings) call psb_tic(idx_matbld)
   call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
        & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
-
+  if (do_timings) call psb_toc(idx_matbld)
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
     goto 9999
@@ -151,14 +160,17 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   ! Now build its descriptor and convert global indices for
   ! ac, op_restr and op_prol
   !
+  if (do_timings) call psb_tic(idx_matasb)
   if (info == psb_success_) &
        & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
        & lv%ac,lv%desc_ac,op_prol,op_restr,info)
-  
+  if (do_timings) call psb_toc(idx_matasb)
+  if (do_timings) call psb_tic(idx_mapbld)  
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
   if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
        & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
+  if (do_timings) call psb_toc(idx_mapbld)  
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
     goto 9999

amgprec/impl/level/amg_d_base_onelev_csetc.F90

@@ -47,6 +47,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
   use amg_d_as_smoother
   use amg_d_diag_solver
   use amg_d_l1_diag_solver
+  use amg_d_jac_solver
   use amg_d_ilu_solver
   use amg_d_id_solver
   use amg_d_gs_solver
@@ -85,6 +86,8 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
   type(amg_d_as_smoother_type)     ::  amg_d_as_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
+  type(amg_d_l1_jac_solver_type)   ::  amg_d_l1_jac_solver_mold
   type(amg_d_ilu_solver_type)      ::  amg_d_ilu_solver_mold
   type(amg_d_id_solver_type)       ::  amg_d_id_solver_mold
   type(amg_d_gs_solver_type)       ::  amg_d_gs_solver_mold
@@ -201,8 +204,13 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
     case ('DIAG')
       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')
       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)
@@ -264,7 +272,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
     end if
 
     select case(val)
-    case('DEC')
+    case('DEC','DECOUPLED')
       allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
     case('SYMDEC')
       allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)

amgprec/impl/level/amg_d_base_onelev_mat_asb.f90

@@ -109,6 +109,8 @@ subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   type(psb_dspmat_type)    :: ac, op_restr, op_prol
   integer(psb_ipk_)        :: nzl, inl
   integer(psb_ipk_)        :: debug_level, debug_unit
+  integer(psb_ipk_), save  :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
+  logical, parameter :: do_timings=.false.
 
   name='amg_d_onelev_mat_asb'
   call psb_erractionsave(err_act)
@@ -120,6 +122,12 @@ subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  if ((do_timings).and.(idx_matbld==-1))       &
+       & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
+  if ((do_timings).and.(idx_matasb==-1))     &
+       & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
+  if ((do_timings).and.(idx_mapbld==-1))       &
+       & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
 
   call amg_check_def(lv%parms%aggr_prol,'Smoother',&
        &   amg_smooth_prol_,is_legal_ml_aggr_prol)
@@ -139,9 +147,10 @@ subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   ! the mapping defined by amg_aggrmap_bld and applying the aggregation
   ! algorithm specified by lv%iprcparm(amg_aggr_prol_)
   !
+  if (do_timings) call psb_tic(idx_matbld)
   call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
        & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
-
+  if (do_timings) call psb_toc(idx_matbld)
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
     goto 9999
@@ -151,14 +160,17 @@ subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   ! Now build its descriptor and convert global indices for
   ! ac, op_restr and op_prol
   !
+  if (do_timings) call psb_tic(idx_matasb)
   if (info == psb_success_) &
        & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
        & lv%ac,lv%desc_ac,op_prol,op_restr,info)
-  
+  if (do_timings) call psb_toc(idx_matasb)
+  if (do_timings) call psb_tic(idx_mapbld)  
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
   if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
        & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
+  if (do_timings) call psb_toc(idx_mapbld)  
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
     goto 9999

amgprec/impl/level/amg_s_base_onelev_csetc.F90

@@ -47,6 +47,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
   use amg_s_as_smoother
   use amg_s_diag_solver
   use amg_s_l1_diag_solver
+  use amg_s_jac_solver
   use amg_s_ilu_solver
   use amg_s_id_solver
   use amg_s_gs_solver
@@ -79,6 +80,8 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
   type(amg_s_as_smoother_type)     ::  amg_s_as_smoother_mold
   type(amg_s_diag_solver_type)     ::  amg_s_diag_solver_mold
   type(amg_s_l1_diag_solver_type)  ::  amg_s_l1_diag_solver_mold
+  type(amg_s_jac_solver_type)      ::  amg_s_jac_solver_mold
+  type(amg_s_l1_jac_solver_type)   ::  amg_s_l1_jac_solver_mold
   type(amg_s_ilu_solver_type)      ::  amg_s_ilu_solver_mold
   type(amg_s_id_solver_type)       ::  amg_s_id_solver_mold
   type(amg_s_gs_solver_type)       ::  amg_s_gs_solver_mold
@@ -189,8 +192,13 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
     case ('DIAG')
       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')
       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)
@@ -244,7 +252,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
     end if
 
     select case(val)
-    case('DEC')
+    case('DEC','DECOUPLED')
       allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info)
     case('SYMDEC')
       allocate(amg_s_symdec_aggregator_type :: lv%aggr, stat=info)

amgprec/impl/level/amg_s_base_onelev_mat_asb.f90

@@ -109,6 +109,8 @@ subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   type(psb_sspmat_type)    :: ac, op_restr, op_prol
   integer(psb_ipk_)        :: nzl, inl
   integer(psb_ipk_)        :: debug_level, debug_unit
+  integer(psb_ipk_), save  :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
+  logical, parameter :: do_timings=.false.
 
   name='amg_s_onelev_mat_asb'
   call psb_erractionsave(err_act)
@@ -120,6 +122,12 @@ subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  if ((do_timings).and.(idx_matbld==-1))       &
+       & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
+  if ((do_timings).and.(idx_matasb==-1))     &
+       & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
+  if ((do_timings).and.(idx_mapbld==-1))       &
+       & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
 
   call amg_check_def(lv%parms%aggr_prol,'Smoother',&
        &   amg_smooth_prol_,is_legal_ml_aggr_prol)
@@ -139,9 +147,10 @@ subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   ! the mapping defined by amg_aggrmap_bld and applying the aggregation
   ! algorithm specified by lv%iprcparm(amg_aggr_prol_)
   !
+  if (do_timings) call psb_tic(idx_matbld)
   call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
        & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
-
+  if (do_timings) call psb_toc(idx_matbld)
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
     goto 9999
@@ -151,14 +160,17 @@ subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   ! Now build its descriptor and convert global indices for
   ! ac, op_restr and op_prol
   !
+  if (do_timings) call psb_tic(idx_matasb)
   if (info == psb_success_) &
        & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
        & lv%ac,lv%desc_ac,op_prol,op_restr,info)
-  
+  if (do_timings) call psb_toc(idx_matasb)
+  if (do_timings) call psb_tic(idx_mapbld)  
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
   if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
        & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
+  if (do_timings) call psb_toc(idx_mapbld)  
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
     goto 9999

amgprec/impl/level/amg_z_base_onelev_csetc.F90

@@ -46,6 +46,7 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
   use amg_z_as_smoother
   use amg_z_diag_solver
   use amg_z_l1_diag_solver
+  use amg_z_jac_solver
   use amg_z_ilu_solver
   use amg_z_id_solver
   use amg_z_gs_solver
@@ -84,6 +85,8 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
   type(amg_z_as_smoother_type)     ::  amg_z_as_smoother_mold
   type(amg_z_diag_solver_type)     ::  amg_z_diag_solver_mold
   type(amg_z_l1_diag_solver_type)  ::  amg_z_l1_diag_solver_mold
+  type(amg_z_jac_solver_type)      ::  amg_z_jac_solver_mold
+  type(amg_z_l1_jac_solver_type)   ::  amg_z_l1_jac_solver_mold
   type(amg_z_ilu_solver_type)      ::  amg_z_ilu_solver_mold
   type(amg_z_id_solver_type)       ::  amg_z_id_solver_mold
   type(amg_z_gs_solver_type)       ::  amg_z_gs_solver_mold
@@ -200,8 +203,13 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
     case ('DIAG')
       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')
       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)
@@ -263,7 +271,7 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
     end if
 
     select case(val)
-    case('DEC')
+    case('DEC','DECOUPLED')
       allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info)
     case('SYMDEC')
       allocate(amg_z_symdec_aggregator_type :: lv%aggr, stat=info)

amgprec/impl/level/amg_z_base_onelev_mat_asb.f90

@@ -109,6 +109,8 @@ subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   type(psb_zspmat_type)    :: ac, op_restr, op_prol
   integer(psb_ipk_)        :: nzl, inl
   integer(psb_ipk_)        :: debug_level, debug_unit
+  integer(psb_ipk_), save  :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
+  logical, parameter :: do_timings=.false.
 
   name='amg_z_onelev_mat_asb'
   call psb_erractionsave(err_act)
@@ -120,6 +122,12 @@ subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  if ((do_timings).and.(idx_matbld==-1))       &
+       & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
+  if ((do_timings).and.(idx_matasb==-1))     &
+       & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
+  if ((do_timings).and.(idx_mapbld==-1))       &
+       & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
 
   call amg_check_def(lv%parms%aggr_prol,'Smoother',&
        &   amg_smooth_prol_,is_legal_ml_aggr_prol)
@@ -139,9 +147,10 @@ subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   ! the mapping defined by amg_aggrmap_bld and applying the aggregation
   ! algorithm specified by lv%iprcparm(amg_aggr_prol_)
   !
+  if (do_timings) call psb_tic(idx_matbld)
   call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
        & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
-
+  if (do_timings) call psb_toc(idx_matbld)
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
     goto 9999
@@ -151,14 +160,17 @@ subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   ! Now build its descriptor and convert global indices for
   ! ac, op_restr and op_prol
   !
+  if (do_timings) call psb_tic(idx_matasb)
   if (info == psb_success_) &
        & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
        & lv%ac,lv%desc_ac,op_prol,op_restr,info)
-  
+  if (do_timings) call psb_toc(idx_matasb)
+  if (do_timings) call psb_tic(idx_mapbld)  
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
   if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
        & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
+  if (do_timings) call psb_toc(idx_mapbld)  
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
     goto 9999

amgprec/impl/solver/Makefile

@@ -197,6 +197,7 @@ amg_z_mumps_solver_bld.o \
 amg_s_ainv_solver_bld.o \
 amg_s_ainv_solver_check.o \
 amg_s_ainv_solver_clone.o \
+amg_s_ainv_solver_clone_settings.o \
 amg_s_ainv_solver_csetc.o \
 amg_s_ainv_solver_cseti.o \
 amg_s_ainv_solver_csetr.o \
@@ -204,6 +205,7 @@ amg_s_ainv_solver_descr.o \
 amg_d_ainv_solver_bld.o \
 amg_d_ainv_solver_check.o \
 amg_d_ainv_solver_clone.o \
+amg_d_ainv_solver_clone_settings.o \
 amg_d_ainv_solver_csetc.o \
 amg_d_ainv_solver_cseti.o \
 amg_d_ainv_solver_csetr.o \
@@ -211,6 +213,7 @@ amg_d_ainv_solver_descr.o \
 amg_c_ainv_solver_bld.o \
 amg_c_ainv_solver_check.o \
 amg_c_ainv_solver_clone.o \
+amg_c_ainv_solver_clone_settings.o \
 amg_c_ainv_solver_csetc.o \
 amg_c_ainv_solver_cseti.o \
 amg_c_ainv_solver_csetr.o \
@@ -218,6 +221,7 @@ amg_c_ainv_solver_descr.o \
 amg_z_ainv_solver_bld.o \
 amg_z_ainv_solver_check.o \
 amg_z_ainv_solver_clone.o \
+amg_z_ainv_solver_clone_settings.o \
 amg_z_ainv_solver_csetc.o \
 amg_z_ainv_solver_cseti.o \
 amg_z_ainv_solver_csetr.o \
@@ -249,48 +253,92 @@ amg_z_base_ainv_update_a.o \
 amg_d_invt_solver_bld.o \
 amg_d_invt_solver_check.o \
 amg_d_invt_solver_clone.o \
+amg_d_invt_solver_clone_settings.o \
 amg_d_invt_solver_cseti.o \
 amg_d_invt_solver_csetr.o \
 amg_d_invt_solver_descr.o \
 amg_d_invk_solver_bld.o \
 amg_d_invk_solver_check.o \
 amg_d_invk_solver_clone.o \
+amg_d_invk_solver_clone_settings.o \
 amg_d_invk_solver_cseti.o \
 amg_d_invk_solver_descr.o \
 amg_s_invt_solver_bld.o \
 amg_s_invt_solver_check.o \
 amg_s_invt_solver_clone.o \
+amg_s_invt_solver_clone_settings.o \
 amg_s_invt_solver_cseti.o \
 amg_s_invt_solver_csetr.o \
 amg_s_invt_solver_descr.o \
 amg_s_invk_solver_bld.o \
 amg_s_invk_solver_check.o \
 amg_s_invk_solver_clone.o \
+amg_s_invk_solver_clone_settings.o \
 amg_s_invk_solver_cseti.o \
 amg_s_invk_solver_descr.o \
 amg_c_invt_solver_bld.o \
 amg_c_invt_solver_check.o \
 amg_c_invt_solver_clone.o \
+amg_c_invt_solver_clone_settings.o \
 amg_c_invt_solver_cseti.o \
 amg_c_invt_solver_csetr.o \
 amg_c_invt_solver_descr.o \
 amg_c_invk_solver_bld.o \
 amg_c_invk_solver_check.o \
 amg_c_invk_solver_clone.o \
+amg_c_invk_solver_clone_settings.o \
 amg_c_invk_solver_cseti.o \
 amg_c_invk_solver_descr.o \
 amg_z_invt_solver_bld.o \
 amg_z_invt_solver_check.o \
 amg_z_invt_solver_clone.o \
+amg_z_invt_solver_clone_settings.o \
 amg_z_invt_solver_cseti.o \
 amg_z_invt_solver_csetr.o \
 amg_z_invt_solver_descr.o \
 amg_z_invk_solver_bld.o \
 amg_z_invk_solver_check.o \
 amg_z_invk_solver_clone.o \
+amg_z_invk_solver_clone_settings.o \
 amg_z_invk_solver_cseti.o \
 amg_z_invk_solver_descr.o \
-amg_z_krm_solver_impl.o 
+amg_z_krm_solver_impl.o \
+amg_c_jac_solver_clone_settings.o \
+amg_c_jac_solver_clear_data.o \
+amg_c_jac_solver_cnv.o \
+amg_c_jac_solver_clone.o \
+amg_c_jac_solver_dmp.o \
+amg_c_jac_solver_apply_vect.o \
+amg_c_jac_solver_apply.o \
+amg_c_jac_solver_bld.o \
+amg_c_l1_jac_solver_bld.o \
+amg_z_jac_solver_clone_settings.o \
+amg_z_jac_solver_clear_data.o \
+amg_z_jac_solver_cnv.o \
+amg_z_jac_solver_clone.o \
+amg_z_jac_solver_dmp.o \
+amg_z_jac_solver_apply_vect.o \
+amg_z_jac_solver_apply.o \
+amg_z_jac_solver_bld.o \
+amg_z_l1_jac_solver_bld.o \
+amg_s_jac_solver_clone_settings.o \
+amg_s_jac_solver_clear_data.o \
+amg_s_jac_solver_cnv.o \
+amg_s_jac_solver_clone.o \
+amg_s_jac_solver_dmp.o \
+amg_s_jac_solver_apply_vect.o \
+amg_s_jac_solver_apply.o \
+amg_s_jac_solver_bld.o \
+amg_s_l1_jac_solver_bld.o \
+amg_d_jac_solver_clone_settings.o \
+amg_d_jac_solver_clear_data.o \
+amg_d_jac_solver_cnv.o \
+amg_d_jac_solver_clone.o \
+amg_d_jac_solver_dmp.o \
+amg_d_jac_solver_apply_vect.o \
+amg_d_jac_solver_apply.o \
+amg_d_jac_solver_bld.o \
+amg_d_l1_jac_solver_bld.o 
 
 LIBNAME=libamg_prec.a
 

amgprec/impl/solver/amg_c_ainv_solver_clone_settings.f90

@@ -0,0 +1,84 @@
+!
+!
+!                             AMG4PSBLAS version 1.0
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!
+!    (C) Copyright 2008,2009,2010,2010,2012
+!
+!                        Salvatore Filippone  University of Rome Tor Vergata
+!                        Alfredo Buttari      CNRS-IRIT, Toulouse
+!                        Pasqua D'Ambra       ICAR-CNR, Naples
+!                        Daniela di Serafino  Second University of Naples
+!
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_ainv_solver_clone_settings(sv,svout,info)
+
+  use psb_base_mod
+  use amg_c_ainv_solver, amg_protect_name => amg_c_ainv_solver_clone_settings
+
+  Implicit None
+
+  ! Arguments
+  class(amg_c_ainv_solver_type), intent(inout)              :: sv
+  class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
+  integer(psb_ipk_), intent(out)                            :: info
+  ! Local variables
+  integer(psb_ipk_) :: err_act
+
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+  if (allocated(svout)) then
+    call svout%free(info)
+    if (info == psb_success_) deallocate(svout, stat=info)
+  end if
+  if (info == psb_success_) &
+       & allocate(amg_c_ainv_solver_type :: svout, stat=info)
+  if (info /= 0) then
+    info = psb_err_alloc_dealloc_
+    goto 9999
+  end if
+  select type(svo => svout)
+  type is (amg_c_ainv_solver_type)
+    svo%alg      = sv%alg
+    svo%fill_in  = sv%fill_in
+    svo%thresh   = sv%thresh
+
+  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_c_ainv_solver_clone_settings

amgprec/impl/solver/amg_c_base_ainv_solver_cnv.f90

@@ -47,7 +47,6 @@ subroutine amg_c_base_ainv_solver_cnv(sv,info,amold,vmold,imold)
   class(psb_i_base_vect_type), intent(in), optional  :: imold
 
   !local
-  integer(psb_ipk_)  :: i, j, il1, iln, lname, lev
   integer(psb_ipk_)  :: iam, np
   type(psb_ctxt_type)   :: ctxt
   character(len=80)  :: prefix_

amgprec/impl/solver/amg_c_bwgs_solver_bld.f90

@@ -56,6 +56,8 @@ subroutine amg_c_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: np, me, i, err_act, debug_unit, debug_level
   character(len=20)   :: name='d_bwgs_solver_bld', ch_err
+  integer(psb_ipk_), save :: idx_tril=-1
+  logical, parameter      :: do_timings=.true.
 
   info=psb_success_
   call psb_erractionsave(err_act)
@@ -65,6 +67,8 @@ subroutine amg_c_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   call psb_info(ctxt, me, np)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),' start'
+  if ((do_timings).and.(idx_tril==-1))       &
+       & idx_tril = psb_get_timer_idx("BWGS_BLD: tril")
 
 
   n_row  = desc_a%get_local_rows()
@@ -77,7 +81,10 @@ subroutine amg_c_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
     ! This cuts out the off-diagonal part, because it's supposed to
     ! be handled by the outer Jacobi smoother.
     !
+    !write(0,*) 'Calling A%TRIL in bwgs_solver_bld'
+    if (do_timings) call psb_tic(idx_tril)
     call a%tril(sv%l,info,diag=-ione,jmax=nrow_a,u=sv%u)     
+    if (do_timings) call psb_toc(idx_tril)
 
   else
 

amgprec/impl/solver/amg_c_diag_solver_bld.f90

@@ -132,8 +132,7 @@ subroutine amg_c_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   class(psb_i_base_vect_type), intent(in), optional   :: imold
   ! Local variables
   integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
-  complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
-  complex(psb_spk_), allocatable :: tdb(:)
+  complex(psb_spk_), allocatable :: tdb(:), tx(:), ty(:) 
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: np, me, i, err_act, debug_unit, debug_level
   character(len=20)   :: name='c_l1_diag_solver_bld', ch_err
@@ -151,12 +150,15 @@ subroutine amg_c_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   n_row  = desc_a%get_local_rows()
   nrow_a = a%get_nrows()
 
+  tx   = a%get_diag(info)
   sv%d = a%arwsum(info)
+  sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) 
   if (info == psb_success_) call psb_realloc(n_row,sv%d,info)
   if (present(b)) then 
     tdb=b%arwsum(info)
+    ty =b%get_diag(info)
     if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info)
-    if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:)
+    if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:)
   end if
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum')

amgprec/impl/solver/amg_c_gs_solver_bld.f90

@@ -56,6 +56,8 @@ subroutine amg_c_gs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: np, me, i, err_act, debug_unit, debug_level
   character(len=20)   :: name='c_gs_solver_bld', ch_err
+  integer(psb_ipk_), save :: idx_tril=-1
+  logical, parameter      :: do_timings=.true.
 
   info=psb_success_
   call psb_erractionsave(err_act)
@@ -65,6 +67,8 @@ subroutine amg_c_gs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   call psb_info(ctxt, me, np)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),' start'
+  if ((do_timings).and.(idx_tril==-1))       &
+       & idx_tril = psb_get_timer_idx("GS_BLD: tril")
 
 
   n_row  = desc_a%get_local_rows()
@@ -76,9 +80,12 @@ subroutine amg_c_gs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
     !
     ! This cuts out the off-diagonal part, because it's supposed to
     ! be handled by the outer Jacobi smoother.
-    ! 
+    !
+    !write(0,*) 'Calling A%TRIL in gs_solver_bld'
+    if (do_timings) call psb_tic(idx_tril)
     call a%tril(sv%l,info,diag=izero,jmax=nrow_a,u=sv%u)
-
+    if (do_timings) call psb_toc(idx_tril)
+    !write(0,*) 'From A%TRIL in gs_solver_bld',a%get_nzeros(),sv%l%get_nzeros(),sv%u%get_nzeros()
   else
 
     info = psb_err_missing_override_method_

amgprec/impl/solver/amg_c_invk_solver_clone_settings.f90

@@ -0,0 +1,83 @@
+!  
+!
+!                             AMG4PSBLAS version 1.0
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!
+!    (C) Copyright 2008,2009,2010,2010,2012
+!
+!                        Salvatore Filippone  University of Rome Tor Vergata
+!                        Alfredo Buttari      CNRS-IRIT, Toulouse
+!                        Pasqua D'Ambra       ICAR-CNR, Naples
+!                        Daniela di Serafino  Second University of Naples
+!
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_invk_solver_clone_settings(sv,svout,info)
+
+  use psb_base_mod
+  use amg_c_invk_solver, amg_protect_name => amg_c_invk_solver_clone_settings
+
+  Implicit None
+
+  ! Arguments
+  class(amg_c_invk_solver_type), intent(inout)              :: sv
+  class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
+  integer(psb_ipk_), intent(out)                            :: info
+  ! Local variables
+  integer(psb_ipk_) :: err_act
+
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+  if (allocated(svout)) then
+    call svout%free(info)
+    if (info == psb_success_) deallocate(svout, stat=info)
+  end if
+  if (info == psb_success_) &
+       & allocate(amg_c_invk_solver_type :: svout, stat=info)
+  if (info /= 0) then
+    info = psb_err_alloc_dealloc_
+    goto 9999
+  end if
+  select type(svo => svout)
+  type is (amg_c_invk_solver_type)
+    svo%fill_in  = sv%fill_in
+    svo%inv_fill = sv%inv_fill
+
+  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_c_invk_solver_clone_settings

amgprec/impl/solver/amg_c_invt_solver_clone_settings.f90

@@ -0,0 +1,85 @@
+!  
+!
+!                             AMG4PSBLAS version 1.0
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!
+!    (C) Copyright 2008,2009,2010,2010,2012
+!
+!                        Salvatore Filippone  University of Rome Tor Vergata
+!                        Alfredo Buttari      CNRS-IRIT, Toulouse
+!                        Pasqua D'Ambra       ICAR-CNR, Naples
+!                        Daniela di Serafino  Second University of Naples
+!
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_invt_solver_clone_settings(sv,svout,info)
+
+  use psb_base_mod
+  use amg_c_invt_solver, amg_protect_name => amg_c_invt_solver_clone_settings
+
+  Implicit None
+
+  ! Arguments
+  class(amg_c_invt_solver_type), intent(inout)              :: sv
+  class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
+  integer(psb_ipk_), intent(out)                            :: info
+  ! Local variables
+  integer(psb_ipk_) :: err_act
+
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+  if (allocated(svout)) then
+    call svout%free(info)
+    if (info == psb_success_) deallocate(svout, stat=info)
+  end if
+  if (info == psb_success_) &
+       & allocate(amg_c_invt_solver_type :: svout, stat=info)
+  if (info /= 0) then
+    info = psb_err_alloc_dealloc_
+    goto 9999
+  end if
+  select type(svo => svout)
+  type is (amg_c_invt_solver_type)
+    svo%fill_in    = sv%fill_in
+    svo%inv_fill   = sv%inv_fill
+    svo%thresh     = sv%thresh
+    svo%inv_thresh = sv%inv_thresh
+
+  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_c_invt_solver_clone_settings

amgprec/impl/solver/amg_c_jac_solver_apply.f90

@@ -0,0 +1,352 @@
+!
+!
+!                             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_c_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,&
+     & work,info,init,initu)
+
+  use psb_base_mod
+  use amg_c_diag_solver
+  use psb_base_krylov_conv_mod, only : log_conv
+  use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_apply
+  implicit none
+  type(psb_desc_type), intent(in)                 :: desc_data
+  class(amg_c_jac_solver_type), intent(inout) :: sv
+  complex(psb_spk_),intent(inout)           :: x(:)
+  complex(psb_spk_),intent(inout)           :: y(:)
+  complex(psb_spk_),intent(in)                      :: alpha,beta
+  character(len=1),intent(in)                     :: trans
+  complex(psb_spk_),target, intent(inout)           :: work(:)
+  integer(psb_ipk_), intent(out)                  :: info
+  character, intent(in), optional                :: init
+  complex(psb_spk_),intent(inout), optional :: initu(:)
+  !
+  integer(psb_ipk_)    :: n_row,n_col, sweeps
+  complex(psb_spk_), pointer :: aux(:)
+  type(psb_ctxt_type) :: ctxt
+  integer(psb_ipk_)   :: np, me, i, err_act
+  character           :: trans_, init_
+  real(psb_dpk_)      :: res, resdenum
+  character(len=20)   :: name='c_jac_solver_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
+
+
+  
+  n_row = desc_data%get_local_rows()
+  n_col = desc_data%get_local_cols()
+  sweeps = sv%sweeps
+  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='complex(psb_spk_)')
+      goto 9999
+    end if
+  endif
+
+  if (sweeps >= 0) then
+      !
+      ! This means we are dealing with a pure Jacobi smoother/solver.
+      !
+      associate(tx => aux(1:n_col), ty => aux(n_col+1:2*n_col))
+        select case (init_)
+        case('Z')
+
+          call inner_mlt(n_row,cone,sv%dv%v%v,x,czero,ty,trans=trans_)
+
+        case('Y')
+          call psb_geaxpby(cone,x,czero,tx,desc_data,info)
+          call psb_geaxpby(cone,y,czero,ty,desc_data,info)
+          call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,&
+               & work=aux,trans=trans_, doswap=.false.)
+          call inner_mlt(n_row,cone,sv%dv%v%v,tx,czero,ty,trans=trans_)
+
+        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(cone,x,czero,tx,desc_data,info)
+          call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
+          call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,&
+               & work=aux,trans=trans_, doswap=.false.)
+          call inner_mlt(n_row,cone,sv%dv%v%v,tx,czero,ty,trans=trans_)
+
+        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(cone,x,czero,tx,desc_data,info)
+          call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,&
+               & work=aux,trans=trans_, doswap=.false.)
+          if (info /= psb_success_) exit
+          call inner_mlt(n_row,cone,sv%dv%v%v,tx,cone,ty,trans=trans_)
+          if (info /= psb_success_) exit
+        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
+
+
+    else
+      
+      info = psb_err_iarg_neg_
+      call psb_errpush(info,name,&
+           & i_err=(/itwo,sweeps,izero,izero,izero/))
+      goto 9999
+      
+    end if
+
+  if (.not.(4*n_col <= size(work))) then
+    deallocate(aux)
+  endif
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+contains
+  subroutine inner_mlt(n_row,alpha,d,x,beta,y,trans)
+    implicit none
+    integer(psb_ipk_),intent(in)   :: n_row
+    complex(psb_spk_), intent(inout) :: d(:)
+    complex(psb_spk_),intent(inout)  :: x(:)
+    complex(psb_spk_),intent(inout)  :: y(:)
+    complex(psb_spk_),intent(in)     :: alpha,beta
+    character(len=1),intent(in)    :: trans
+
+    integer(psb_ipk_) :: i
+    
+    if (trans_ == 'C') then 
+      if (beta == czero) then 
+
+        if (alpha == czero) then 
+          y(1:n_row) = czero
+        else if (alpha == cone) then 
+          do i=1, n_row
+            y(i) = conjg(d(i)) * x(i)
+          end do
+        else if (alpha == -cone) then 
+          do i=1, n_row
+            y(i) = -conjg(d(i)) * x(i)
+          end do
+        else
+          do i=1, n_row
+            y(i) = alpha * conjg(d(i)) * x(i)
+          end do
+        end if
+
+      else if (beta == cone) then 
+
+        if (alpha == czero) then 
+          !y(1:n_row) = czero
+        else if (alpha == cone) then 
+          do i=1, n_row
+            y(i) = conjg(d(i)) * x(i) + y(i)
+          end do
+        else if (alpha == -cone) then 
+          do i=1, n_row
+            y(i) = -conjg(d(i)) * x(i)  + y(i)
+          end do
+        else
+          do i=1, n_row
+            y(i) = alpha * conjg(d(i)) * x(i) + y(i)
+          end do
+        end if
+
+      else if (beta == -cone) then 
+
+        if (alpha == czero) then 
+          y(1:n_row) = -y(1:n_row)        
+        else if (alpha == cone) then 
+          do i=1, n_row
+            y(i) = conjg(d(i)) * x(i) - y(i)
+          end do
+        else if (alpha == -cone) then 
+          do i=1, n_row
+            y(i) = -conjg(d(i)) * x(i)  - y(i)
+          end do
+        else
+          do i=1, n_row
+            y(i) = alpha * conjg(d(i)) * x(i) - y(i)
+          end do
+        end if
+
+      else
+
+        if (alpha == czero) then 
+          y(1:n_row) = beta *y(1:n_row)        
+        else if (alpha == cone) then 
+          do i=1, n_row
+            y(i) = conjg(d(i)) * x(i) + beta*y(i)
+          end do
+        else if (alpha == -cone) then 
+          do i=1, n_row
+            y(i) = -conjg(d(i)) * x(i)  + beta*y(i)
+          end do
+        else
+          do i=1, n_row
+            y(i) = alpha * conjg(d(i)) * x(i) + beta*y(i)
+          end do
+        end if
+
+      end if
+
+    else if (trans_ /= 'C') then 
+
+      if (beta == czero) then 
+
+        if (alpha == czero) then 
+          y(1:n_row) = czero
+        else if (alpha == cone) then 
+          do i=1, n_row
+            y(i) = d(i) * x(i)
+          end do
+        else if (alpha == -cone) then 
+          do i=1, n_row
+            y(i) = -d(i) * x(i)
+          end do
+        else
+          do i=1, n_row
+            y(i) = alpha * d(i) * x(i)
+          end do
+        end if
+
+      else if (beta == cone) then 
+
+        if (alpha == czero) then 
+          !y(1:n_row) = czero
+        else if (alpha == cone) then 
+          do i=1, n_row
+            y(i) = d(i) * x(i) + y(i)
+          end do
+        else if (alpha == -cone) then 
+          do i=1, n_row
+            y(i) = -d(i) * x(i)  + y(i)
+          end do
+        else
+          do i=1, n_row
+            y(i) = alpha * d(i) * x(i) + y(i)
+          end do
+        end if
+
+      else if (beta == -cone) then 
+
+        if (alpha == czero) then 
+          y(1:n_row) = -y(1:n_row)        
+        else if (alpha == cone) then 
+          do i=1, n_row
+            y(i) = d(i) * x(i) - y(i)
+          end do
+        else if (alpha == -cone) then 
+          do i=1, n_row
+            y(i) = -d(i) * x(i)  - y(i)
+          end do
+        else
+          do i=1, n_row
+            y(i) = alpha * d(i) * x(i) - y(i)
+          end do
+        end if
+
+      else
+
+        if (alpha == czero) then 
+          y(1:n_row) = beta *y(1:n_row)        
+        else if (alpha == cone) then 
+          do i=1, n_row
+            y(i) = d(i) * x(i) + beta*y(i)
+          end do
+        else if (alpha == -cone) then 
+          do i=1, n_row
+            y(i) = -d(i) * x(i)  + beta*y(i)
+          end do
+        else
+          do i=1, n_row
+            y(i) = alpha * d(i) * x(i) + beta*y(i)
+          end do
+        end if
+
+      end if
+
+    end if
+
+  end subroutine inner_mlt
+end subroutine amg_c_jac_solver_apply

amgprec/impl/solver/amg_c_jac_solver_apply_vect.f90

@@ -0,0 +1,190 @@
+!
+!
+!                             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_c_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,&
+     & work,wv,info,init,initu)
+
+  use psb_base_mod
+  use amg_c_diag_solver
+  use psb_base_krylov_conv_mod, only : log_conv
+  use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_apply_vect
+  implicit none
+  type(psb_desc_type), intent(in)                 :: desc_data
+  class(amg_c_jac_solver_type), intent(inout) :: sv
+  type(psb_c_vect_type),intent(inout)           :: x
+  type(psb_c_vect_type),intent(inout)           :: y
+  complex(psb_spk_),intent(in)                      :: alpha,beta
+  character(len=1),intent(in)                     :: trans
+  complex(psb_spk_),target, intent(inout)           :: work(:)
+  type(psb_c_vect_type),intent(inout)           :: wv(:)
+  integer(psb_ipk_), intent(out)                  :: info
+  character, intent(in), optional                :: init
+  type(psb_c_vect_type),intent(inout), optional   :: initu
+  !
+  integer(psb_ipk_)    :: n_row,n_col, sweeps
+  type(psb_c_vect_type)  :: tx, ty, r
+  complex(psb_spk_), pointer :: aux(:)
+  type(psb_ctxt_type) :: ctxt
+  integer(psb_ipk_)   :: np, me, i, err_act
+  character           :: trans_, init_
+  real(psb_dpk_)      :: res, resdenum
+  character(len=20)   :: name='c_jac_solver_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
+
+
+  
+  n_row = desc_data%get_local_rows()
+  n_col = desc_data%get_local_cols()
+  sweeps = sv%sweeps
+  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='complex(psb_spk_)')
+      goto 9999
+    end if
+  endif
+
+  if (sweeps >= 0) then
+      !
+      ! This means we are dealing with a pure Jacobi smoother/solver.
+      !
+      associate(tx => wv(1), ty => wv(2))
+        select case (init_)
+        case('Z')
+
+          call ty%mlt(cone,sv%dv,x,czero,info,conjgx=trans_)
+
+        case('Y')
+          call psb_geaxpby(cone,x,czero,tx,desc_data,info)
+          call psb_geaxpby(cone,y,czero,ty,desc_data,info)
+          call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,&
+               & work=aux,trans=trans_, doswap=.false.)
+          call ty%mlt(cone,sv%dv,tx,czero,info,conjgx=trans_)
+
+        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(cone,x,czero,tx,desc_data,info)
+          call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
+          call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,&
+               & work=aux,trans=trans_, doswap=.false.)
+          call ty%mlt(cone,sv%dv,tx,czero,info,conjgx=trans_)
+
+        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(cone,x,czero,tx,desc_data,info)
+          call psb_spmm(-cone,sv%a,ty,cone,tx,desc_data,info,&
+               & work=aux,trans=trans_, doswap=.false.)
+          if (info /= psb_success_) exit
+          call ty%mlt(cone,sv%dv,tx,cone,info,conjgx=trans_)
+          if (info /= psb_success_) exit
+        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
+
+
+    else
+      
+      info = psb_err_iarg_neg_
+      call psb_errpush(info,name,&
+           & i_err=(/itwo,sweeps,izero,izero,izero/))
+      goto 9999
+      
+    end if
+
+  if (.not.(4*n_col <= size(work))) then
+    deallocate(aux)
+  endif
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+
+end subroutine amg_c_jac_solver_apply_vect

amgprec/impl/solver/amg_c_jac_solver_bld.f90

@@ -0,0 +1,125 @@
+!  
+!   
+!                             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_c_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+  
+  use psb_base_mod
+  use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_bld
+
+  Implicit None
+
+  ! Arguments
+  type(psb_cspmat_type), intent(in), target           :: a
+  Type(psb_desc_type), Intent(inout)                  :: desc_a 
+  class(amg_c_jac_solver_type), intent(inout)        :: sv
+  integer(psb_ipk_), intent(out)                      :: info
+  type(psb_cspmat_type), intent(in), target, optional :: b
+  class(psb_c_base_sparse_mat), intent(in), optional  :: amold
+  class(psb_c_base_vect_type), intent(in), optional   :: vmold
+  class(psb_i_base_vect_type), intent(in), optional   :: imold
+  ! Local variables
+  integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
+  complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
+  complex(psb_spk_), allocatable :: tdb(:)
+  type(psb_c_csr_sparse_mat) :: tcsr
+  type(psb_ctxt_type) :: ctxt
+  integer(psb_ipk_)   :: np, me, i, err_act, debug_unit, debug_level
+  character(len=20)   :: name='c_jac_solver_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()
+  nrow_a = a%get_nrows()
+  if (present(b)) then
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999      
+  end if
+  call a%cp_to(tcsr)
+  call sv%a%mv_from(tcsr)
+  if (present(amold)) call sv%a%cscnv(info,mold=amold)
+  
+  sv%d = a%get_diag(info)
+  if (info == psb_success_) call psb_realloc(n_row,sv%d,info)
+  if (present(b)) then 
+    tdb=b%get_diag(info)
+    if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info)
+    if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:)
+  end if
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag')
+    goto 9999      
+  end if
+
+  do i=1,n_row
+    if (sv%d(i) == czero) then 
+      sv%d(i) = cone
+    else
+      sv%d(i) = cone/sv%d(i)
+    end if
+  end do
+  allocate(sv%dv,stat=info) 
+  if (info == psb_success_) then 
+    call sv%dv%bld(sv%d)
+    if (present(vmold)) call sv%dv%cnv(vmold)
+    call sv%dv%sync()
+  else
+    call psb_errpush(psb_err_from_subroutine_,name,& 
+         & a_err='Allocate sv%dv')
+    goto 9999      
+  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_c_jac_solver_bld
+
+

amgprec/impl/solver/amg_c_jac_solver_clear_data.f90

@@ -0,0 +1,65 @@
+!  
+!   
+!                             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_c_jac_solver_clear_data(sv,info)
+  
+  use psb_base_mod
+  use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_clear_data
+
+  Implicit None
+
+  ! Arguments
+  class(amg_c_jac_solver_type), intent(inout) :: sv
+  integer(psb_ipk_), intent(out)               :: info
+  ! Local variables
+  integer(psb_ipk_) :: err_act
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+  call sv%a%free()
+  call sv%dv%free(info)
+  if ((info==0).and.allocated(sv%d)) deallocate(sv%d,stat=info)
+  if (info /= 0) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+end subroutine amg_c_jac_solver_clear_data

amgprec/impl/solver/amg_c_jac_solver_clone.f90

@@ -0,0 +1,88 @@
+!  
+!   
+!                             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_c_jac_solver_clone(sv,svout,info)
+  
+  use psb_base_mod
+  use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_clone
+
+  Implicit None
+
+  ! Arguments
+  class(amg_c_jac_solver_type), intent(inout)               :: sv
+  class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
+  integer(psb_ipk_), intent(out)              :: info
+  ! Local variables
+  integer(psb_ipk_) :: err_act
+
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+  if (allocated(svout)) then
+    call svout%free(info)
+    if (info == psb_success_) deallocate(svout, stat=info)
+  end if
+  if (info == psb_success_) &
+       & allocate(svout, mold=sv, stat=info)
+  if (info /= 0) then 
+    info = psb_err_alloc_dealloc_
+    goto 9999 
+  end if
+
+  select type(svo => svout)
+  class is (amg_c_jac_solver_type)
+    svo%sweeps = sv%sweeps
+    svo%eps    = sv%eps
+    if (info == psb_success_) &
+         & call sv%a%clone(svo%a,info)
+    if (info == psb_success_) &
+         & call sv%dv%clone(svo%dv,info)
+    svo%d = sv%d
+    
+  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_c_jac_solver_clone

amgprec/impl/solver/amg_c_jac_solver_clone_settings.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   
+!        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_c_jac_solver_clone_settings(sv,svout,info)
+  
+  use psb_base_mod
+  use amg_c_jac_solver, amg_protect_name =>  amg_c_jac_solver_clone_settings
+  Implicit None
+  ! Arguments
+  class(amg_c_jac_solver_type), intent(inout) :: sv
+  class(amg_c_base_solver_type), intent(inout) :: svout
+  integer(psb_ipk_), intent(out)                 :: info
+  integer(psb_ipk_)  :: err_act
+  character(len=20) :: name='c_jac_solver_clone_settings'
+
+  call psb_erractionsave(err_act)
+
+  select type(svout)
+  class is(amg_c_jac_solver_type)
+    svout%sweeps = sv%sweeps
+    svout%eps    = sv%eps
+    
+  class default    
+    info = psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999 
+  end select
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+end subroutine amg_c_jac_solver_clone_settings

amgprec/impl/solver/amg_c_jac_solver_cnv.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   
+!        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_c_jac_solver_cnv(sv,info,amold,vmold,imold)
+
+  use psb_base_mod
+  use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_cnv
+
+  Implicit None
+
+  ! Arguments
+  class(amg_c_jac_solver_type), intent(inout)         :: sv
+  integer(psb_ipk_), intent(out)                        :: info
+  class(psb_c_base_sparse_mat), intent(in), optional  :: amold
+  class(psb_c_base_vect_type), intent(in), optional   :: vmold
+  class(psb_i_base_vect_type), intent(in), optional  :: imold
+  ! Local variables
+  integer(psb_ipk_) :: err_act, debug_unit, debug_level
+  character(len=20) :: name='c_jac_solver_cnv', ch_err
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  if (present(amold)) call sv%a%cscnv(info,mold=amold)
+  if ((info==0).and.present(vmold)) call sv%dv%cnv(mold=vmold)
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) trim(name),' end'
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+end subroutine amg_c_jac_solver_cnv

amgprec/impl/solver/amg_c_jac_solver_dmp.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   
+!        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_c_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
+
+  use psb_base_mod
+  use amg_c_jac_solver, amg_protect_name => amg_c_jac_solver_dmp
+  implicit none 
+  class(amg_c_jac_solver_type), intent(in) :: sv
+  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)              :: 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
+  logical :: solver_, global_num_
+  integer(psb_lpk_), allocatable :: iv(:)
+  !  len of prefix_ 
+
+  info = 0
+
+  ctxt = desc%get_context()
+  call psb_info(ctxt,iam,np)
+
+  if (present(solver)) then 
+    solver_ = solver
+  else
+    solver_ = .false. 
+  end if
+  if (present(global_num)) then 
+    global_num_ = global_num
+  else
+    global_num_ = .false. 
+  end if
+
+
+  if (solver_) then 
+    if (present(prefix)) then 
+      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+    else
+      prefix_ = "dump_slv_c"
+    end if
+    lname = len_trim(prefix_)
+    fname = trim(prefix_)
+    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+    lname = lname + 5
+    
+    if (global_num_) then
+      iv = desc%get_global_indices(owned=.false.)      
+
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
+      if (sv%a%is_asb()) &
+           & call sv%a%print(fname,head=head,iv=iv)
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx'
+      if (allocated(sv%dv)) &
+           & call psb_geprt(fname,sv%dv%v%v,head=head)
+      
+    else
+
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
+      if (sv%a%is_asb()) &
+           & call sv%a%print(fname,head=head)
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_diag.mtx'
+      if (allocated(sv%dv)) &
+           & call psb_geprt(fname,sv%dv%v%v,head=head)
+    end if
+  end if
+
+end subroutine amg_c_jac_solver_dmp

amgprec/impl/solver/amg_c_l1_jac_solver_bld.f90

@@ -0,0 +1,128 @@
+!  
+!   
+!                             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_c_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+  
+  use psb_base_mod
+  use amg_c_jac_solver, amg_protect_name => amg_c_l1_jac_solver_bld
+
+  Implicit None
+
+  ! Arguments
+  type(psb_cspmat_type), intent(in), target           :: a
+  Type(psb_desc_type), Intent(inout)                  :: desc_a 
+  class(amg_c_l1_jac_solver_type), intent(inout)        :: sv
+  integer(psb_ipk_), intent(out)                      :: info
+  type(psb_cspmat_type), intent(in), target, optional :: b
+  class(psb_c_base_sparse_mat), intent(in), optional  :: amold
+  class(psb_c_base_vect_type), intent(in), optional   :: vmold
+  class(psb_i_base_vect_type), intent(in), optional   :: imold
+  ! Local variables
+  integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
+  complex(psb_spk_), allocatable :: tdb(:), tx(:),ty(:)
+  type(psb_c_csr_sparse_mat) :: tcsr
+  type(psb_ctxt_type) :: ctxt
+  integer(psb_ipk_)   :: np, me, i, err_act, debug_unit, debug_level
+  character(len=20)   :: name='c_l1_jac_solver_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()
+  nrow_a = a%get_nrows()
+  if (present(b)) then
+    info=psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999      
+  end if
+    
+  call a%cp_to(tcsr)
+  call sv%a%mv_from(tcsr)
+  if (present(amold)) call sv%a%cscnv(info,mold=amold)
+  
+  tx   = a%get_diag(info)
+  sv%d = a%arwsum(info)
+  sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) 
+  if (info == psb_success_) call psb_realloc(n_row,sv%d,info)
+  if (present(b)) then 
+    tdb=b%arwsum(info)
+    ty =b%get_diag(info)
+    if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info)
+    if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:)
+  end if
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag')
+    goto 9999      
+  end if
+
+  do i=1,n_row
+    if (sv%d(i) == czero) then 
+      sv%d(i) = cone
+    else
+      sv%d(i) = cone/sv%d(i)
+    end if
+  end do
+  allocate(sv%dv,stat=info) 
+  if (info == psb_success_) then 
+    call sv%dv%bld(sv%d)
+    if (present(vmold)) call sv%dv%cnv(vmold)
+    call sv%dv%sync()
+  else
+    call psb_errpush(psb_err_from_subroutine_,name,& 
+         & a_err='Allocate sv%dv')
+    goto 9999      
+  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_c_l1_jac_solver_bld
+
+

amgprec/impl/solver/amg_d_ainv_solver_clone_settings.f90

@@ -0,0 +1,84 @@
+!
+!
+!                             AMG4PSBLAS version 1.0
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!
+!    (C) Copyright 2008,2009,2010,2010,2012
+!
+!                        Salvatore Filippone  University of Rome Tor Vergata
+!                        Alfredo Buttari      CNRS-IRIT, Toulouse
+!                        Pasqua D'Ambra       ICAR-CNR, Naples
+!                        Daniela di Serafino  Second University of Naples
+!
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_ainv_solver_clone_settings(sv,svout,info)
+
+  use psb_base_mod
+  use amg_d_ainv_solver, amg_protect_name => amg_d_ainv_solver_clone_settings
+
+  Implicit None
+
+  ! Arguments
+  class(amg_d_ainv_solver_type), intent(inout)              :: sv
+  class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
+  integer(psb_ipk_), intent(out)                            :: info
+  ! Local variables
+  integer(psb_ipk_) :: err_act
+
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+  if (allocated(svout)) then
+    call svout%free(info)
+    if (info == psb_success_) deallocate(svout, stat=info)
+  end if
+  if (info == psb_success_) &
+       & allocate(amg_d_ainv_solver_type :: svout, stat=info)
+  if (info /= 0) then
+    info = psb_err_alloc_dealloc_
+    goto 9999
+  end if
+  select type(svo => svout)
+  type is (amg_d_ainv_solver_type)
+    svo%alg      = sv%alg
+    svo%fill_in  = sv%fill_in
+    svo%thresh   = sv%thresh
+
+  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_ainv_solver_clone_settings

amgprec/impl/solver/amg_d_base_ainv_solver_cnv.f90

@@ -47,7 +47,6 @@ subroutine amg_d_base_ainv_solver_cnv(sv,info,amold,vmold,imold)
   class(psb_i_base_vect_type), intent(in), optional  :: imold
 
   !local
-  integer(psb_ipk_)  :: i, j, il1, iln, lname, lev
   integer(psb_ipk_)  :: iam, np
   type(psb_ctxt_type)   :: ctxt
   character(len=80)  :: prefix_

amgprec/impl/solver/amg_d_bwgs_solver_bld.f90

@@ -56,6 +56,8 @@ subroutine amg_d_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: np, me, i, err_act, debug_unit, debug_level
   character(len=20)   :: name='d_bwgs_solver_bld', ch_err
+  integer(psb_ipk_), save :: idx_tril=-1
+  logical, parameter      :: do_timings=.true.
 
   info=psb_success_
   call psb_erractionsave(err_act)
@@ -65,6 +67,8 @@ subroutine amg_d_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   call psb_info(ctxt, me, np)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),' start'
+  if ((do_timings).and.(idx_tril==-1))       &
+       & idx_tril = psb_get_timer_idx("BWGS_BLD: tril")
 
 
   n_row  = desc_a%get_local_rows()
@@ -77,7 +81,10 @@ subroutine amg_d_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
     ! This cuts out the off-diagonal part, because it's supposed to
     ! be handled by the outer Jacobi smoother.
     !
+    !write(0,*) 'Calling A%TRIL in bwgs_solver_bld'
+    if (do_timings) call psb_tic(idx_tril)
     call a%tril(sv%l,info,diag=-ione,jmax=nrow_a,u=sv%u)     
+    if (do_timings) call psb_toc(idx_tril)
 
   else
 

amgprec/impl/solver/amg_d_diag_solver_bld.f90

@@ -132,8 +132,7 @@ subroutine amg_d_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   class(psb_i_base_vect_type), intent(in), optional   :: imold
   ! Local variables
   integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
-  real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
-  real(psb_dpk_), allocatable :: tdb(:)
+  real(psb_dpk_), allocatable :: tdb(:), tx(:), ty(:) 
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: np, me, i, err_act, debug_unit, debug_level
   character(len=20)   :: name='d_l1_diag_solver_bld', ch_err
@@ -151,12 +150,15 @@ subroutine amg_d_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   n_row  = desc_a%get_local_rows()
   nrow_a = a%get_nrows()
 
+  tx   = a%get_diag(info)
   sv%d = a%arwsum(info)
+  sv%d(:) = sv%d(:) - abs(tx(:)) + tx(:) 
   if (info == psb_success_) call psb_realloc(n_row,sv%d,info)
   if (present(b)) then 
     tdb=b%arwsum(info)
+    ty =b%get_diag(info)
     if (size(tdb)+nrow_a > n_row) call psb_realloc(nrow_a+size(tdb),sv%d,info)
-    if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:)
+    if (info == psb_success_) sv%d(nrow_a+1:nrow_a+size(tdb)) = tdb(:) - abs(ty(:)) + ty(:)
   end if
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_from_subroutine_,name,a_err='arwsum')

amgprec/impl/solver/amg_d_gs_solver_bld.f90

@@ -56,6 +56,8 @@ subroutine amg_d_gs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: np, me, i, err_act, debug_unit, debug_level
   character(len=20)   :: name='d_gs_solver_bld', ch_err
+  integer(psb_ipk_), save :: idx_tril=-1
+  logical, parameter      :: do_timings=.true.
 
   info=psb_success_
   call psb_erractionsave(err_act)
@@ -65,6 +67,8 @@ subroutine amg_d_gs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
   call psb_info(ctxt, me, np)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),' start'
+  if ((do_timings).and.(idx_tril==-1))       &
+       & idx_tril = psb_get_timer_idx("GS_BLD: tril")
 
 
   n_row  = desc_a%get_local_rows()
@@ -76,9 +80,12 @@ subroutine amg_d_gs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
     !
     ! This cuts out the off-diagonal part, because it's supposed to
     ! be handled by the outer Jacobi smoother.
-    ! 
+    !
+    !write(0,*) 'Calling A%TRIL in gs_solver_bld'
+    if (do_timings) call psb_tic(idx_tril)
     call a%tril(sv%l,info,diag=izero,jmax=nrow_a,u=sv%u)
-
+    if (do_timings) call psb_toc(idx_tril)
+    !write(0,*) 'From A%TRIL in gs_solver_bld',a%get_nzeros(),sv%l%get_nzeros(),sv%u%get_nzeros()
   else
 
     info = psb_err_missing_override_method_

amgprec/impl/solver/amg_d_invk_solver_clone_settings.f90

@@ -0,0 +1,83 @@
+!  
+!
+!                             AMG4PSBLAS version 1.0
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!
+!    (C) Copyright 2008,2009,2010,2010,2012
+!
+!                        Salvatore Filippone  University of Rome Tor Vergata
+!                        Alfredo Buttari      CNRS-IRIT, Toulouse
+!                        Pasqua D'Ambra       ICAR-CNR, Naples
+!                        Daniela di Serafino  Second University of Naples
+!
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_invk_solver_clone_settings(sv,svout,info)
+
+  use psb_base_mod
+  use amg_d_invk_solver, amg_protect_name => amg_d_invk_solver_clone_settings
+
+  Implicit None
+
+  ! Arguments
+  class(amg_d_invk_solver_type), intent(inout)              :: sv
+  class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
+  integer(psb_ipk_), intent(out)                            :: info
+  ! Local variables
+  integer(psb_ipk_) :: err_act
+
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+  if (allocated(svout)) then
+    call svout%free(info)
+    if (info == psb_success_) deallocate(svout, stat=info)
+  end if
+  if (info == psb_success_) &
+       & allocate(amg_d_invk_solver_type :: svout, stat=info)
+  if (info /= 0) then
+    info = psb_err_alloc_dealloc_
+    goto 9999
+  end if
+  select type(svo => svout)
+  type is (amg_d_invk_solver_type)
+    svo%fill_in  = sv%fill_in
+    svo%inv_fill = sv%inv_fill
+
+  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_invk_solver_clone_settings

amgprec/impl/solver/amg_d_invt_solver_clone_settings.f90

@@ -0,0 +1,85 @@
+!  
+!
+!                             AMG4PSBLAS version 1.0
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!
+!    (C) Copyright 2008,2009,2010,2010,2012
+!
+!                        Salvatore Filippone  University of Rome Tor Vergata
+!                        Alfredo Buttari      CNRS-IRIT, Toulouse
+!                        Pasqua D'Ambra       ICAR-CNR, Naples
+!                        Daniela di Serafino  Second University of Naples
+!
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_invt_solver_clone_settings(sv,svout,info)
+
+  use psb_base_mod
+  use amg_d_invt_solver, amg_protect_name => amg_d_invt_solver_clone_settings
+
+  Implicit None
+
+  ! Arguments
+  class(amg_d_invt_solver_type), intent(inout)              :: sv
+  class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
+  integer(psb_ipk_), intent(out)                            :: info
+  ! Local variables
+  integer(psb_ipk_) :: err_act
+
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+  if (allocated(svout)) then
+    call svout%free(info)
+    if (info == psb_success_) deallocate(svout, stat=info)
+  end if
+  if (info == psb_success_) &
+       & allocate(amg_d_invt_solver_type :: svout, stat=info)
+  if (info /= 0) then
+    info = psb_err_alloc_dealloc_
+    goto 9999
+  end if
+  select type(svo => svout)
+  type is (amg_d_invt_solver_type)
+    svo%fill_in    = sv%fill_in
+    svo%inv_fill   = sv%inv_fill
+    svo%thresh     = sv%thresh
+    svo%inv_thresh = sv%inv_thresh
+
+  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_invt_solver_clone_settings