Fix input file

This reverts commit a17f503486.

.gitignore

@@ -12,9 +12,9 @@ config.log
 config.status
 
 # generated folder
-include/
-modules/
-docs/src/tmp
+/include/
+/modules/
+/docs/src/tmp
 autom4te.cache
 
 # the executable from tests

Make.inc.in

@@ -75,7 +75,7 @@ CDEFINES=$(AMGCDEFINES)
 AMGFDEFINES=@AMGFDEFINES@ $(PSBFDEFINES)
 FDEFINES=$(AMGFDEFINES)
 
-CXXDEFINES=@AMGCXXDEFINES@
+CXXDEFINES=@AMGCXXDEFINES@ $(PSBCXXDEFINES)
 
 @COMPILERULES@
 

Makefile

@@ -3,9 +3,9 @@ include Make.inc
 
 all:  objs lib
 
-objs: amgp cbnd
+objs: libdir amgp cbnd
 
-lib: libdir objs
+lib:  objs
 	cd amgprec && $(MAKE) lib
 	cd cbind && $(MAKE)  lib
 

amgprec/Makefile

@@ -9,9 +9,10 @@ FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES)
 
 DMODOBJS=amg_d_prec_type.o \
 	amg_d_inner_mod.o amg_d_ilu_solver.o amg_d_diag_solver.o amg_d_jac_smoother.o amg_d_as_smoother.o \
+        amg_d_poly_smoother.o amg_d_poly_coeff_mod.o\
 	amg_d_umf_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o amg_d_id_solver.o\
 	amg_d_base_solver_mod.o amg_d_base_smoother_mod.o amg_d_onelev_mod.o \
-	amg_d_gs_solver.o amg_d_mumps_solver.o \
+	amg_d_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 \
@@ -20,9 +21,9 @@ DMODOBJS=amg_d_prec_type.o \
 
 SMODOBJS=amg_s_prec_type.o amg_s_ilu_fact_mod.o \
 	amg_s_inner_mod.o amg_s_ilu_solver.o amg_s_diag_solver.o amg_s_jac_smoother.o amg_s_as_smoother.o \
-	amg_s_slu_solver.o amg_s_id_solver.o\
+	amg_s_poly_smoother.o amg_s_slu_solver.o amg_s_id_solver.o\
 	amg_s_base_solver_mod.o amg_s_base_smoother_mod.o amg_s_onelev_mod.o  \
-	amg_s_gs_solver.o amg_s_mumps_solver.o \
+	amg_s_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 +34,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 +44,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 +156,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
@@ -164,9 +165,11 @@ amg_d_jac_smoother.o: amg_d_diag_solver.o
 amg_dprecinit.o amg_dprecset.o: amg_d_diag_solver.o amg_d_ilu_solver.o \
 		amg_d_umf_solver.o amg_d_as_smoother.o amg_d_jac_smoother.o \
 	        amg_d_id_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o
+amg_d_poly_smoother.o: amg_d_base_smoother_mod.o amg_d_poly_coeff_mod.o
+amg_s_poly_smoother.o: amg_s_base_smoother_mod.o amg_d_poly_coeff_mod.o	
 
 amg_s_mumps_solver.o amg_s_gs_solver.o amg_s_id_solver.o amg_s_slu_solver.o \
-amg_s_diag_solver.o amg_s_ilu_solver.o: amg_s_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 +179,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 +189,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_base_prec_type.F90

@@ -94,6 +94,7 @@ module amg_base_prec_type
     integer(psb_ipk_) :: aggr_omega_alg, aggr_eig, aggr_filter
     integer(psb_ipk_) :: coarse_mat, coarse_solve
   contains
+    procedure, pass(pm) :: get_coarse_mat  => ml_parms_get_coarse_mat
     procedure, pass(pm) :: get_coarse  => ml_parms_get_coarse
     procedure, pass(pm) :: clone       => ml_parms_clone
     procedure, pass(pm) :: descr       => ml_parms_descr
@@ -214,7 +215,8 @@ module amg_base_prec_type
   integer(psb_ipk_), parameter :: amg_fbgs_     = 6
   integer(psb_ipk_), parameter :: amg_l1_gs_    = 7
   integer(psb_ipk_), parameter :: amg_l1_fbgs_  = 8
-  integer(psb_ipk_), parameter :: amg_max_prec_ = 8
+  integer(psb_ipk_), parameter :: amg_poly_     = 9
+  integer(psb_ipk_), parameter :: amg_max_prec_ = 9
   !
   ! Constants for pre/post signaling. Now only used internally
   !
@@ -232,9 +234,9 @@ module amg_base_prec_type
   integer(psb_ipk_), parameter :: amg_diag_scale_    = amg_slv_delta_+1
   integer(psb_ipk_), parameter :: amg_l1_diag_scale_ = amg_slv_delta_+2
   integer(psb_ipk_), parameter :: amg_gs_            = amg_slv_delta_+3
-  ! !$  integer(psb_ipk_), parameter :: amg_ilu_n_         = amg_slv_delta_+4
-  ! !$  integer(psb_ipk_), parameter :: amg_milu_n_        = amg_slv_delta_+5
-  ! !$  integer(psb_ipk_), parameter :: amg_ilu_t_         = amg_slv_delta_+6
+  integer(psb_ipk_), parameter :: amg_ilu_n_         = amg_slv_delta_+4
+  integer(psb_ipk_), parameter :: amg_milu_n_        = amg_slv_delta_+5
+  integer(psb_ipk_), parameter :: amg_ilu_t_         = amg_slv_delta_+6
   integer(psb_ipk_), parameter :: amg_slu_           = amg_slv_delta_+7
   integer(psb_ipk_), parameter :: amg_umf_           = amg_slv_delta_+8
   integer(psb_ipk_), parameter :: amg_sludist_       = amg_slv_delta_+9
@@ -286,11 +288,12 @@ module amg_base_prec_type
   !
   ! Legal values for entry: amg_aggr_prol_
   !
-  integer(psb_ipk_), parameter :: amg_no_smooth_   = 0
-  integer(psb_ipk_), parameter :: amg_smooth_prol_ = 1
-  integer(psb_ipk_), parameter :: amg_min_energy_  = 2
+  integer(psb_ipk_), parameter :: amg_no_smooth_      = 0
+  integer(psb_ipk_), parameter :: amg_smooth_prol_    = 1
+  integer(psb_ipk_), parameter :: amg_l1_smooth_prol_ = 2
+  integer(psb_ipk_), parameter :: amg_min_energy_     = 3
   ! Disabling min_energy  for the time being.
-  integer(psb_ipk_), parameter :: amg_max_aggr_prol_=amg_smooth_prol_
+  integer(psb_ipk_), parameter :: amg_max_aggr_prol_= amg_l1_smooth_prol_
   !
   ! Legal values for entry: amg_aggr_filter_
   !
@@ -318,6 +321,16 @@ module amg_base_prec_type
   integer(psb_ipk_), parameter :: amg_distr_mat_      = 0
   integer(psb_ipk_), parameter :: amg_repl_mat_       = 1
   integer(psb_ipk_), parameter :: amg_max_coarse_mat_ = amg_repl_mat_
+  !
+  ! Legal values for entry: amg_poly_variant_
+  !
+  integer(psb_ipk_), parameter :: amg_cheb_4_     = 0
+  integer(psb_ipk_), parameter :: amg_cheb_4_opt_ = 1
+  integer(psb_ipk_), parameter :: amg_cheb_1_opt_ = 2
+  integer(psb_ipk_), parameter :: amg_poly_dbg_   = 8
+  
+  integer(psb_ipk_), parameter :: amg_poly_rho_est_power_ = 0
+
   !
   ! Legal values for entry: amg_prec_status_
   !
@@ -364,8 +377,8 @@ module amg_base_prec_type
   character(len=19), parameter, private :: &
        &  eigen_estimates(0:0)=(/'infinity norm     '/)
   character(len=15), parameter, private :: &
-       &  aggr_prols(0:3)=(/'unsmoothed    ','smoothed      ',&
-       &           'min energy    ','bizr. smoothed'/)
+       &  aggr_prols(0:4)=(/'unsmoothed    ','smoothed      ',&
+       &  'l1-smoothed   ','min energy    ','bizr. smoothed'/)
   character(len=15), parameter, private :: &
        &  aggr_filters(0:1)=(/'no filtering  ','filtering     '/)
   character(len=15), parameter, private :: &
@@ -389,12 +402,12 @@ module amg_base_prec_type
        &  ml_names(0:7)=(/'none          ','additive      ',&
        &  'multiplicative', 'VCycle        ','WCycle        ',&
        &  'KCycle        ','KCycleSym     ','new ML        '/)
-  character(len=15), parameter :: &
+  character(len=16), parameter :: &
        &  amg_fact_names(0:amg_max_sub_solve_)=(/&
        & 'none          ','Jacobi        ',&
        & 'L1-Jacobi     ','none          ','none          ',&
        & 'none          ','none          ','L1-GS         ',&
-       & 'L1-FBGS       ','none          ','Point Jacobi  ',&
+       & 'L1-FBGS       ','Polynomial    ','none          ','Point Jacobi  ',&
        & 'L1-Jacobi     ','Gauss-Seidel  ','ILU(n)        ',&
        & 'MILU(n)       ','ILU(t,n)      ',&
        & 'SuperLU       ','UMFPACK LU    ',&
@@ -456,12 +469,12 @@ contains
     character(len=*), parameter :: name='amg_stringval'
   ! Local variable
     integer :: index_tab
-    character(len=15) ::string2
+    character(len=128) ::string2
     index_tab=index(string,char(9))
     if (index_tab.NE.0)  then
-       string2=string(1:index_tab-1)
+      string2=string(1:index_tab-1)
     else
-       string2=string
+      string2=string
     endif
     select case(psb_toupper(trim(string2)))
     case('NONE')
@@ -481,11 +494,11 @@ contains
     case('BGS','BWGS')
       val = amg_bwgs_
     case('ILU')
-      val = psb_ilu_n_
+      val = amg_ilu_n_
     case('MILU')
-      val = psb_milu_n_
+      val = amg_milu_n_
     case('ILUT')
-      val = psb_ilu_t_
+      val = amg_ilu_t_
     case('MUMPS')
       val = amg_mumps_
     case('UMF')
@@ -536,6 +549,8 @@ contains
       val = amg_no_smooth_
     case('SMOOTHED')
       val = amg_smooth_prol_
+    case('L1-SMOOTHED','L1SMOOTHED')
+      val = amg_l1_smooth_prol_
     case('MINENERGY')
       val = amg_min_energy_
     case('NOPREC')
@@ -556,6 +571,18 @@ contains
       val = amg_krm_
     case('AS')
       val = amg_as_
+    case('POLY')
+      val = amg_poly_
+    case('CHEB_4')
+      val = amg_cheb_4_
+    case('CHEB_4_OPT')
+      val = amg_cheb_4_opt_
+    case('CHEB_1_OPT')
+      val = amg_cheb_1_opt_
+    case('POLY_DBG')
+      val = amg_poly_dbg_
+    case('POLY_RHO_EST_POWER')
+      val =  amg_poly_rho_est_power_
     case('A_NORMI')
       val = amg_max_norm_
     case('USER_CHOICE')
@@ -577,6 +604,33 @@ contains
     end select
   end function amg_stringval
 
+  function amg_get_coarse_mat_name(val) result(res)
+    character(len=15) :: res
+    integer :: val
+    select case(val)
+    case (0,1)
+      res = matrix_names(val)
+    case default
+      res = 'Unknown '
+    end select
+  end function amg_get_coarse_mat_name
+
+  subroutine amg_warn_coarse_mat(val,expected)
+    integer(psb_ipk_) :: val, expected
+    if (val /= expected) then
+      write(0,*) 'Warning: resetting COARSE_MAT on an existing hierarchy from ',&
+           & amg_get_coarse_mat_name(val), ' to ',amg_get_coarse_mat_name(expected)
+    end if
+  end subroutine amg_warn_coarse_mat
+
+  
+  function  ml_parms_get_coarse_mat(pm) result(res)
+    implicit none
+    class(amg_ml_parms), intent(in)    :: pm
+    integer(psb_ipk_) :: res
+    res   = pm%coarse_mat
+  end function ml_parms_get_coarse_mat
+
   subroutine  ml_parms_get_coarse(pm,pmin)
     implicit none
     class(amg_ml_parms), intent(inout) :: pm
@@ -639,10 +693,10 @@ contains
            &   ml_names(pm%ml_cycle)
       select case (pm%ml_cycle)
       case (amg_add_ml_)
-        write(iout,*) '  Number of smoother sweeps : ',&
+        write(iout,*) '  Number of smoother sweeps/degree : ',&
              & pm%sweeps_pre
       case (amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_, amg_kcycle_ml_, amg_kcyclesym_ml_)
-        write(iout,*) '  Number of smoother sweeps : pre: ',&
+        write(iout,*) '  Number of smoother sweeps/degree : pre: ',&
              &  pm%sweeps_pre ,'  post: ', pm%sweeps_post
       end select
 
@@ -1008,8 +1062,8 @@ contains
     integer(psb_ipk_), intent(in) :: ip
     logical             :: is_legal_ilu_fact
 
-    is_legal_ilu_fact = ((ip==psb_ilu_n_).or.&
-         & (ip==psb_milu_n_).or.(ip==psb_ilu_t_))
+    is_legal_ilu_fact = ((ip==amg_ilu_n_).or.&
+         & (ip==amg_milu_n_).or.(ip==amg_ilu_t_))
     return
   end function is_legal_ilu_fact
   function is_legal_d_omega(ip)

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_ilu_solver.f90

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

amgprec/amg_c_inner_mod.f90

@@ -109,11 +109,12 @@ module amg_c_inner_mod
   end interface amg_map_to_tprol
 
   abstract interface
-    subroutine amg_caggrmat_var_bld(a,desc_a,ilaggr,nlaggr,parms,&
+    subroutine amg_caggrmat_var_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,parms,&
          & ac,desc_ac,op_prol,op_restr,t_prol,info)
       import :: psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_, psb_lcspmat_type
       import ::  amg_c_onelev_type, amg_sml_parms
       implicit none 
+      integer(psb_ipk_), intent(in)               :: dol1smoothing
       type(psb_cspmat_type), intent(in)         :: a
       type(psb_desc_type), intent(inout)          :: desc_a
       integer(psb_lpk_), intent(inout)            :: ilaggr(:), nlaggr(:)

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,585 @@
+!  
+!   
+!                             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()
+    if (allocated(sv%dv)) then
+      call sv%dv%free(info)
+      deallocate(sv%dv)
+    end if
+    if (allocated(sv%d)) deallocate(sv%d)
+
+    call psb_erractionrestore(err_act)
+    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_c_onelev_mod.f90

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

amgprec/amg_c_prec_type.f90

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

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_ilu_solver.f90

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

amgprec/amg_d_inner_mod.f90

@@ -109,11 +109,12 @@ module amg_d_inner_mod
   end interface amg_map_to_tprol
 
   abstract interface
-    subroutine amg_daggrmat_var_bld(a,desc_a,ilaggr,nlaggr,parms,&
+    subroutine amg_daggrmat_var_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,parms,&
          & ac,desc_ac,op_prol,op_restr,t_prol,info)
       import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_, psb_ldspmat_type
       import ::  amg_d_onelev_type, amg_dml_parms
       implicit none 
+      integer(psb_ipk_), intent(in)               :: dol1smoothing
       type(psb_dspmat_type), intent(in)         :: a
       type(psb_desc_type), intent(inout)          :: desc_a
       integer(psb_lpk_), intent(inout)            :: ilaggr(:), nlaggr(:)

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,585 @@
+!  
+!   
+!                             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()
+    if (allocated(sv%dv)) then
+      call sv%dv%free(info)
+      deallocate(sv%dv)
+    end if
+    if (allocated(sv%d)) deallocate(sv%d)
+
+    call psb_erractionrestore(err_act)
+    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_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_d_onelev_mod.f90

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

amgprec/amg_d_parmatch_aggregator_mod.F90

@@ -244,11 +244,12 @@ module amg_d_parmatch_aggregator_mod
   end interface
 
   interface
-    subroutine amg_d_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
+    subroutine amg_d_parmatch_unsmth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,parms,&
          & ac,desc_ac,op_prol,op_restr,t_prol,info)
       import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
            & psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
       implicit none
+      integer(psb_ipk_), intent(in) :: dol1smoothing
       class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
       type(psb_dspmat_type), intent(in)       :: a
       type(psb_desc_type), intent(inout)      :: desc_a
@@ -262,11 +263,12 @@ module amg_d_parmatch_aggregator_mod
   end interface
 
   interface
-    subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
+    subroutine amg_d_parmatch_smth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,parms,&
          & ac,desc_ac,op_prol,op_restr,t_prol,info)
       import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
            & psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
       implicit none
+      integer(psb_ipk_), intent(in) :: dol1smoothing
       class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
       type(psb_dspmat_type), intent(in)       :: a
       type(psb_desc_type), intent(inout)      :: desc_a

amgprec/amg_d_poly_coeff_mod.f90

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

amgprec/amg_d_poly_smoother.f90

@@ -0,0 +1,374 @@
+!
+!
+!                             AMG4PSBLAS version 1.0
+!    Algebraic Multigrid Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.7)
+!
+!    (C) Copyright 2021
+!
+!        Salvatore Filippone
+!        Pasqua D'Ambra
+!        Daniela di Serafino
+!
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the AMG4PSBLAS group or the names of its contributors may
+!         not be used to endorse or promote products derived from this
+!         software without specific written permission.
+!
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
+!    BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!    CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!    ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!    POSSIBILITY OF SUCH DAMAGE.
+!
+!
+!
+! File: amg_d_poly_smoother_mod.f90
+!
+! Module: amg_d_poly_smoother_mod
+!
+!  This module defines:
+!    the amg_d_poly_smoother_type data structure containing the
+!    smoother for a Jacobi/block Jacobi smoother.
+!  The smoother stores in ND the block off-diagonal matrix.
+!  One special case is treated separately, when the solver is DIAG or L1-DIAG
+!  then the ND is the entire off-diagonal part of the matrix (including the
+!  main diagonal block), so that it becomes possible to implement
+!  a pure Jacobi or L1-Jacobi global solver.
+!
+module amg_d_poly_smoother
+  use amg_d_base_smoother_mod
+  use amg_d_poly_coeff_mod
+  
+  type, extends(amg_d_base_smoother_type) :: amg_d_poly_smoother_type
+    ! The local solver component is inherited from the
+    ! parent type.
+    !    class(amg_d_base_solver_type), allocatable :: sv
+    !
+    integer(psb_ipk_)              :: pdegree, variant
+    integer(psb_ipk_)              :: rho_estimate=amg_poly_rho_est_power_
+    integer(psb_ipk_)              :: rho_estimate_iterations=10
+    type(psb_dspmat_type), pointer :: pa => null()
+    real(psb_dpk_), allocatable    :: poly_beta(:)
+    real(psb_dpk_)                 :: cf_a = dzero
+    real(psb_dpk_)                 :: rho_ba = -done
+  contains
+    procedure, pass(sm) :: apply_v => amg_d_poly_smoother_apply_vect
+!!$    procedure, pass(sm) :: apply_a => amg_d_poly_smoother_apply
+    procedure, pass(sm) :: dump    => amg_d_poly_smoother_dmp
+    procedure, pass(sm) :: build   => amg_d_poly_smoother_bld
+    procedure, pass(sm) :: cnv     => amg_d_poly_smoother_cnv
+    procedure, pass(sm) :: clone   => amg_d_poly_smoother_clone
+    procedure, pass(sm) :: clone_settings => amg_d_poly_smoother_clone_settings
+    procedure, pass(sm) :: clear_data     => amg_d_poly_smoother_clear_data  
+    procedure, pass(sm) :: free    => d_poly_smoother_free
+    procedure, pass(sm) :: cseti   => amg_d_poly_smoother_cseti
+    procedure, pass(sm) :: csetc   => amg_d_poly_smoother_csetc
+    procedure, pass(sm) :: csetr   => amg_d_poly_smoother_csetr
+    procedure, pass(sm) :: descr   => amg_d_poly_smoother_descr
+    procedure, pass(sm) :: sizeof  => d_poly_smoother_sizeof
+    procedure, pass(sm) :: default => d_poly_smoother_default
+    procedure, pass(sm) :: get_nzeros => d_poly_smoother_get_nzeros
+    procedure, pass(sm) :: get_wrksz => d_poly_smoother_get_wrksize
+    procedure, nopass   :: get_fmt    => d_poly_smoother_get_fmt
+    procedure, nopass   :: get_id     => d_poly_smoother_get_id
+  end type amg_d_poly_smoother_type
+  private :: d_poly_smoother_free, &
+       & d_poly_smoother_sizeof,  d_poly_smoother_get_nzeros, &
+       & d_poly_smoother_get_fmt, d_poly_smoother_get_id, &
+       & d_poly_smoother_get_wrksize
+
+
+  interface
+    subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
+         & sweeps,work,wv,info,init,initu)
+      import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
+           & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
+           & psb_ipk_
+
+      type(psb_desc_type), intent(in)                 :: desc_data
+      class(amg_d_poly_smoother_type), intent(inout) :: sm
+      type(psb_d_vect_type),intent(inout)           :: x
+      type(psb_d_vect_type),intent(inout)           :: y
+      real(psb_dpk_),intent(in)                      :: alpha,beta
+      character(len=1),intent(in)                     :: trans
+      integer(psb_ipk_), intent(in)                   :: sweeps
+      real(psb_dpk_),target, intent(inout)           :: work(:)
+      type(psb_d_vect_type),intent(inout)           :: wv(:)
+      integer(psb_ipk_), intent(out)                  :: info
+      character, intent(in), optional                :: init
+      type(psb_d_vect_type),intent(inout), optional   :: initu
+    end subroutine amg_d_poly_smoother_apply_vect
+  end interface
+
+!!$  interface
+!!$    subroutine amg_d_poly_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
+!!$         & sweeps,work,info,init,initu)
+!!$      import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
+!!$           & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, &
+!!$           & psb_ipk_
+!!$      type(psb_desc_type), intent(in)      :: desc_data
+!!$      class(amg_d_poly_smoother_type), intent(inout) :: sm
+!!$      real(psb_dpk_),intent(inout)         :: x(:)
+!!$      real(psb_dpk_),intent(inout)         :: y(:)
+!!$      real(psb_dpk_),intent(in)            :: alpha,beta
+!!$      character(len=1),intent(in)           :: trans
+!!$      integer(psb_ipk_), intent(in)         :: sweeps
+!!$      real(psb_dpk_),target, intent(inout) :: work(:)
+!!$      integer(psb_ipk_), intent(out)        :: info
+!!$      character, intent(in), optional       :: init
+!!$      real(psb_dpk_),intent(inout), optional :: initu(:)
+!!$    end subroutine amg_d_poly_smoother_apply
+!!$  end interface
+!!$
+  
+  interface
+    subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
+      import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
+           & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      type(psb_dspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a
+      class(amg_d_poly_smoother_type), intent(inout)       :: sm
+      integer(psb_ipk_), intent(out)                      :: info
+      class(psb_d_base_sparse_mat), intent(in), optional :: amold
+      class(psb_d_base_vect_type), intent(in), optional  :: vmold
+      class(psb_i_base_vect_type), intent(in), optional  :: imold
+    end subroutine amg_d_poly_smoother_bld
+  end interface
+
+  interface
+    subroutine amg_d_poly_smoother_cnv(sm,info,amold,vmold,imold)
+      import :: amg_d_poly_smoother_type, psb_dpk_, &
+           & psb_d_base_sparse_mat, psb_d_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      class(amg_d_poly_smoother_type), intent(inout)       :: sm
+      integer(psb_ipk_), intent(out)                      :: info
+      class(psb_d_base_sparse_mat), intent(in), optional :: amold
+      class(psb_d_base_vect_type), intent(in), optional  :: vmold
+      class(psb_i_base_vect_type), intent(in), optional  :: imold
+    end subroutine amg_d_poly_smoother_cnv
+  end interface
+
+  interface
+    subroutine amg_d_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, &
+           & psb_ipk_
+      implicit none
+      class(amg_d_poly_smoother_type), intent(in) :: sm
+      type(psb_desc_type), intent(in)               :: desc
+      integer(psb_ipk_), intent(in)               :: level
+      integer(psb_ipk_), intent(out)              :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: smoother, solver, global_num
+    end subroutine amg_d_poly_smoother_dmp
+  end interface
+
+  interface
+    subroutine amg_d_poly_smoother_clone(sm,smout,info)
+      import :: amg_d_poly_smoother_type, psb_dpk_, &
+           & amg_d_base_smoother_type, psb_ipk_
+      class(amg_d_poly_smoother_type), intent(inout)               :: sm
+      class(amg_d_base_smoother_type), allocatable, intent(inout) :: smout
+      integer(psb_ipk_), intent(out)                :: info
+    end subroutine amg_d_poly_smoother_clone
+  end interface
+
+  interface
+    subroutine amg_d_poly_smoother_clone_settings(sm,smout,info)
+      import :: amg_d_poly_smoother_type, psb_dpk_, &
+           & amg_d_base_smoother_type, psb_ipk_
+      class(amg_d_poly_smoother_type), intent(inout)               :: sm
+      class(amg_d_base_smoother_type), allocatable, intent(inout) :: smout
+      integer(psb_ipk_), intent(out)                :: info
+    end subroutine amg_d_poly_smoother_clone_settings
+  end interface
+
+  interface
+    subroutine amg_d_poly_smoother_clear_data(sm,info)
+      import :: amg_d_poly_smoother_type, psb_dpk_, &
+           & amg_d_base_smoother_type, psb_ipk_
+      class(amg_d_poly_smoother_type), intent(inout)               :: sm
+      integer(psb_ipk_), intent(out)                :: info
+    end subroutine amg_d_poly_smoother_clear_data
+  end interface
+
+  interface
+    subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix)
+      import :: amg_d_poly_smoother_type, psb_ipk_
+      class(amg_d_poly_smoother_type), intent(in) :: sm
+      integer(psb_ipk_), intent(out)               :: info
+      integer(psb_ipk_), intent(in), optional      :: iout
+      logical, intent(in), optional                :: coarse
+      character(len=*), intent(in), optional       :: prefix
+    end subroutine amg_d_poly_smoother_descr
+  end interface
+
+  interface
+    subroutine amg_d_poly_smoother_cseti(sm,what,val,info,idx)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
+      implicit none
+      class(amg_d_poly_smoother_type), intent(inout) :: sm
+      character(len=*), intent(in)                   :: what
+      integer(psb_ipk_), intent(in)                  :: val
+      integer(psb_ipk_), intent(out)                 :: info
+      integer(psb_ipk_), intent(in), optional        :: idx
+    end subroutine amg_d_poly_smoother_cseti
+  end interface
+
+  interface
+    subroutine amg_d_poly_smoother_csetc(sm,what,val,info,idx)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
+      implicit none
+      class(amg_d_poly_smoother_type), intent(inout) :: sm
+      character(len=*), intent(in)                   :: what
+      character(len=*), intent(in)                   :: val
+      integer(psb_ipk_), intent(out)                 :: info
+      integer(psb_ipk_), intent(in), optional        :: idx
+    end subroutine amg_d_poly_smoother_csetc
+  end interface
+
+  interface
+    subroutine amg_d_poly_smoother_csetr(sm,what,val,info,idx)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
+      implicit none
+      class(amg_d_poly_smoother_type), intent(inout) :: sm
+      character(len=*), intent(in)                   :: what
+      real(psb_dpk_), intent(in)                   :: val
+      integer(psb_ipk_), intent(out)                 :: info
+      integer(psb_ipk_), intent(in), optional        :: idx
+    end subroutine amg_d_poly_smoother_csetr
+  end interface
+
+
+contains
+
+
+  subroutine d_poly_smoother_free(sm,info)
+
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_poly_smoother_type), intent(inout) :: sm
+    integer(psb_ipk_), intent(out)                  :: info
+    integer(psb_ipk_) :: err_act
+    character(len=20)  :: name='d_poly_smoother_free'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+
+
+    if (allocated(sm%sv)) then
+      call sm%sv%free(info)
+      if (info == psb_success_) deallocate(sm%sv,stat=info)
+      if (info /= psb_success_) then
+        info = psb_err_alloc_dealloc_
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+    end if
+    if (allocated(sm%poly_beta))  deallocate(sm%poly_beta)
+    sm%pa => null()
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine d_poly_smoother_free
+
+  function d_poly_smoother_sizeof(sm) result(val)
+
+    implicit none
+    ! Arguments
+    class(amg_d_poly_smoother_type), intent(in) :: sm
+    integer(psb_epk_) :: val
+
+    val = psb_sizeof_dp
+    if (allocated(sm%sv)) val = val + sm%sv%sizeof()
+    if (allocated(sm%poly_beta)) val = val + psb_sizeof_dp * size(sm%poly_beta)
+
+    return
+  end function d_poly_smoother_sizeof
+
+  subroutine d_poly_smoother_default(sm)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_d_poly_smoother_type), intent(inout) :: sm
+
+    !
+    ! Default: BJAC with no residual check
+    !
+    sm%pdegree      = 1
+    sm%rho_ba       = -done
+    sm%variant      = amg_cheb_4_
+    sm%rho_estimate = amg_poly_rho_est_power_
+    sm%rho_estimate_iterations = 20
+    if (allocated(sm%sv)) then
+      call sm%sv%default()
+    end if
+
+    return
+  end subroutine d_poly_smoother_default
+
+  function d_poly_smoother_get_nzeros(sm) result(val)
+
+    implicit none
+    ! Arguments
+    class(amg_d_poly_smoother_type), intent(in) :: sm
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+
+    val = 0
+    if (allocated(sm%sv)) val = val + sm%sv%get_nzeros()
+
+    return
+  end function d_poly_smoother_get_nzeros
+
+  function d_poly_smoother_get_wrksize(sm) result(val)
+    implicit none
+    class(amg_d_poly_smoother_type), intent(inout) :: sm
+    integer(psb_ipk_)  :: val
+
+    val = 4
+    if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
+
+  end function d_poly_smoother_get_wrksize
+
+  function d_poly_smoother_get_fmt() result(val)
+    implicit none
+    character(len=32)  :: val
+
+    val = "Polynomial smoother"
+  end function d_poly_smoother_get_fmt
+
+  function d_poly_smoother_get_id() result(val)
+    implicit none
+    integer(psb_ipk_)  :: val
+
+    val = amg_poly_
+  end function d_poly_smoother_get_id
+
+
+end module amg_d_poly_smoother

amgprec/amg_d_prec_type.f90

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

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_ilu_solver.f90

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

amgprec/amg_s_inner_mod.f90

@@ -109,11 +109,12 @@ module amg_s_inner_mod
   end interface amg_map_to_tprol
 
   abstract interface
-    subroutine amg_saggrmat_var_bld(a,desc_a,ilaggr,nlaggr,parms,&
+    subroutine amg_saggrmat_var_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,parms,&
          & ac,desc_ac,op_prol,op_restr,t_prol,info)
       import :: psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_, psb_lsspmat_type
       import ::  amg_s_onelev_type, amg_sml_parms
       implicit none 
+      integer(psb_ipk_), intent(in)               :: dol1smoothing
       type(psb_sspmat_type), intent(in)         :: a
       type(psb_desc_type), intent(inout)          :: desc_a
       integer(psb_lpk_), intent(inout)            :: ilaggr(:), nlaggr(:)

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,585 @@
+!  
+!   
+!                             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()
+    if (allocated(sv%dv)) then
+      call sv%dv%free(info)
+      deallocate(sv%dv)
+    end if
+    if (allocated(sv%d)) deallocate(sv%d)
+
+    call psb_erractionrestore(err_act)
+    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_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_s_onelev_mod.f90

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

amgprec/amg_s_parmatch_aggregator_mod.F90

@@ -244,11 +244,12 @@ module amg_s_parmatch_aggregator_mod
   end interface
 
   interface
-    subroutine amg_s_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
+    subroutine amg_s_parmatch_unsmth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,parms,&
          & ac,desc_ac,op_prol,op_restr,t_prol,info)
       import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
            & psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
       implicit none
+      integer(psb_ipk_), intent(in) :: dol1smoothing
       class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
       type(psb_sspmat_type), intent(in)       :: a
       type(psb_desc_type), intent(inout)      :: desc_a
@@ -262,11 +263,12 @@ module amg_s_parmatch_aggregator_mod
   end interface
 
   interface
-    subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
+    subroutine amg_s_parmatch_smth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,parms,&
          & ac,desc_ac,op_prol,op_restr,t_prol,info)
       import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
            & psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
       implicit none
+      integer(psb_ipk_), intent(in) :: dol1smoothing
       class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
       type(psb_sspmat_type), intent(in)       :: a
       type(psb_desc_type), intent(inout)      :: desc_a

amgprec/amg_s_poly_smoother.f90

@@ -0,0 +1,374 @@
+!
+!
+!                             AMG4PSBLAS version 1.0
+!    Algebraic Multigrid Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.7)
+!
+!    (C) Copyright 2021
+!
+!        Salvatore Filippone
+!        Pasqua D'Ambra
+!        Daniela di Serafino
+!
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the AMG4PSBLAS group or the names of its contributors may
+!         not be used to endorse or promote products derived from this
+!         software without specific written permission.
+!
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
+!    BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!    CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!    ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!    POSSIBILITY OF SUCH DAMAGE.
+!
+!
+!
+! File: amg_s_poly_smoother_mod.f90
+!
+! Module: amg_s_poly_smoother_mod
+!
+!  This module defines:
+!    the amg_s_poly_smoother_type data structure containing the
+!    smoother for a Jacobi/block Jacobi smoother.
+!  The smoother stores in ND the block off-diagonal matrix.
+!  One special case is treated separately, when the solver is DIAG or L1-DIAG
+!  then the ND is the entire off-diagonal part of the matrix (including the
+!  main diagonal block), so that it becomes possible to implement
+!  a pure Jacobi or L1-Jacobi global solver.
+!
+module amg_s_poly_smoother
+  use amg_s_base_smoother_mod
+  use amg_d_poly_coeff_mod
+  
+  type, extends(amg_s_base_smoother_type) :: amg_s_poly_smoother_type
+    ! The local solver component is inherited from the
+    ! parent type.
+    !    class(amg_s_base_solver_type), allocatable :: sv
+    !
+    integer(psb_ipk_)              :: pdegree, variant
+    integer(psb_ipk_)              :: rho_estimate=amg_poly_rho_est_power_
+    integer(psb_ipk_)              :: rho_estimate_iterations=10
+    type(psb_sspmat_type), pointer :: pa => null()
+    real(psb_spk_), allocatable    :: poly_beta(:)
+    real(psb_spk_)                 :: cf_a = szero
+    real(psb_spk_)                 :: rho_ba = -sone
+  contains
+    procedure, pass(sm) :: apply_v => amg_s_poly_smoother_apply_vect
+!!$    procedure, pass(sm) :: apply_a => amg_s_poly_smoother_apply
+    procedure, pass(sm) :: dump    => amg_s_poly_smoother_dmp
+    procedure, pass(sm) :: build   => amg_s_poly_smoother_bld
+    procedure, pass(sm) :: cnv     => amg_s_poly_smoother_cnv
+    procedure, pass(sm) :: clone   => amg_s_poly_smoother_clone
+    procedure, pass(sm) :: clone_settings => amg_s_poly_smoother_clone_settings
+    procedure, pass(sm) :: clear_data     => amg_s_poly_smoother_clear_data  
+    procedure, pass(sm) :: free    => s_poly_smoother_free
+    procedure, pass(sm) :: cseti   => amg_s_poly_smoother_cseti
+    procedure, pass(sm) :: csetc   => amg_s_poly_smoother_csetc
+    procedure, pass(sm) :: csetr   => amg_s_poly_smoother_csetr
+    procedure, pass(sm) :: descr   => amg_s_poly_smoother_descr
+    procedure, pass(sm) :: sizeof  => s_poly_smoother_sizeof
+    procedure, pass(sm) :: default => s_poly_smoother_default
+    procedure, pass(sm) :: get_nzeros => s_poly_smoother_get_nzeros
+    procedure, pass(sm) :: get_wrksz => s_poly_smoother_get_wrksize
+    procedure, nopass   :: get_fmt    => s_poly_smoother_get_fmt
+    procedure, nopass   :: get_id     => s_poly_smoother_get_id
+  end type amg_s_poly_smoother_type
+  private :: s_poly_smoother_free, &
+       & s_poly_smoother_sizeof,  s_poly_smoother_get_nzeros, &
+       & s_poly_smoother_get_fmt, s_poly_smoother_get_id, &
+       & s_poly_smoother_get_wrksize
+
+
+  interface
+    subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
+         & sweeps,work,wv,info,init,initu)
+      import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
+           & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
+           & psb_ipk_
+
+      type(psb_desc_type), intent(in)                 :: desc_data
+      class(amg_s_poly_smoother_type), intent(inout) :: sm
+      type(psb_s_vect_type),intent(inout)           :: x
+      type(psb_s_vect_type),intent(inout)           :: y
+      real(psb_spk_),intent(in)                      :: alpha,beta
+      character(len=1),intent(in)                     :: trans
+      integer(psb_ipk_), intent(in)                   :: sweeps
+      real(psb_spk_),target, intent(inout)           :: work(:)
+      type(psb_s_vect_type),intent(inout)           :: wv(:)
+      integer(psb_ipk_), intent(out)                  :: info
+      character, intent(in), optional                :: init
+      type(psb_s_vect_type),intent(inout), optional   :: initu
+    end subroutine amg_s_poly_smoother_apply_vect
+  end interface
+
+!!$  interface
+!!$    subroutine amg_s_poly_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
+!!$         & sweeps,work,info,init,initu)
+!!$      import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
+!!$           & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, &
+!!$           & psb_ipk_
+!!$      type(psb_desc_type), intent(in)      :: desc_data
+!!$      class(amg_s_poly_smoother_type), intent(inout) :: sm
+!!$      real(psb_spk_),intent(inout)         :: x(:)
+!!$      real(psb_spk_),intent(inout)         :: y(:)
+!!$      real(psb_spk_),intent(in)            :: alpha,beta
+!!$      character(len=1),intent(in)           :: trans
+!!$      integer(psb_ipk_), intent(in)         :: sweeps
+!!$      real(psb_spk_),target, intent(inout) :: work(:)
+!!$      integer(psb_ipk_), intent(out)        :: info
+!!$      character, intent(in), optional       :: init
+!!$      real(psb_spk_),intent(inout), optional :: initu(:)
+!!$    end subroutine amg_s_poly_smoother_apply
+!!$  end interface
+!!$
+  
+  interface
+    subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
+      import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
+           & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      type(psb_sspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(inout)                  :: desc_a
+      class(amg_s_poly_smoother_type), intent(inout)       :: sm
+      integer(psb_ipk_), intent(out)                      :: info
+      class(psb_s_base_sparse_mat), intent(in), optional :: amold
+      class(psb_s_base_vect_type), intent(in), optional  :: vmold
+      class(psb_i_base_vect_type), intent(in), optional  :: imold
+    end subroutine amg_s_poly_smoother_bld
+  end interface
+
+  interface
+    subroutine amg_s_poly_smoother_cnv(sm,info,amold,vmold,imold)
+      import :: amg_s_poly_smoother_type, psb_spk_, &
+           & psb_s_base_sparse_mat, psb_s_base_vect_type,&
+           & psb_ipk_, psb_i_base_vect_type
+      class(amg_s_poly_smoother_type), intent(inout)       :: sm
+      integer(psb_ipk_), intent(out)                      :: info
+      class(psb_s_base_sparse_mat), intent(in), optional :: amold
+      class(psb_s_base_vect_type), intent(in), optional  :: vmold
+      class(psb_i_base_vect_type), intent(in), optional  :: imold
+    end subroutine amg_s_poly_smoother_cnv
+  end interface
+
+  interface
+    subroutine amg_s_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, &
+           & psb_ipk_
+      implicit none
+      class(amg_s_poly_smoother_type), intent(in) :: sm
+      type(psb_desc_type), intent(in)               :: desc
+      integer(psb_ipk_), intent(in)               :: level
+      integer(psb_ipk_), intent(out)              :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: smoother, solver, global_num
+    end subroutine amg_s_poly_smoother_dmp
+  end interface
+
+  interface
+    subroutine amg_s_poly_smoother_clone(sm,smout,info)
+      import :: amg_s_poly_smoother_type, psb_spk_, &
+           & amg_s_base_smoother_type, psb_ipk_
+      class(amg_s_poly_smoother_type), intent(inout)               :: sm
+      class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
+      integer(psb_ipk_), intent(out)                :: info
+    end subroutine amg_s_poly_smoother_clone
+  end interface
+
+  interface
+    subroutine amg_s_poly_smoother_clone_settings(sm,smout,info)
+      import :: amg_s_poly_smoother_type, psb_spk_, &
+           & amg_s_base_smoother_type, psb_ipk_
+      class(amg_s_poly_smoother_type), intent(inout)               :: sm
+      class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
+      integer(psb_ipk_), intent(out)                :: info
+    end subroutine amg_s_poly_smoother_clone_settings
+  end interface
+
+  interface
+    subroutine amg_s_poly_smoother_clear_data(sm,info)
+      import :: amg_s_poly_smoother_type, psb_spk_, &
+           & amg_s_base_smoother_type, psb_ipk_
+      class(amg_s_poly_smoother_type), intent(inout)               :: sm
+      integer(psb_ipk_), intent(out)                :: info
+    end subroutine amg_s_poly_smoother_clear_data
+  end interface
+
+  interface
+    subroutine amg_s_poly_smoother_descr(sm,info,iout,coarse,prefix)
+      import :: amg_s_poly_smoother_type, psb_ipk_
+      class(amg_s_poly_smoother_type), intent(in) :: sm
+      integer(psb_ipk_), intent(out)               :: info
+      integer(psb_ipk_), intent(in), optional      :: iout
+      logical, intent(in), optional                :: coarse
+      character(len=*), intent(in), optional       :: prefix
+    end subroutine amg_s_poly_smoother_descr
+  end interface
+
+  interface
+    subroutine amg_s_poly_smoother_cseti(sm,what,val,info,idx)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
+      implicit none
+      class(amg_s_poly_smoother_type), intent(inout) :: sm
+      character(len=*), intent(in)                   :: what
+      integer(psb_ipk_), intent(in)                  :: val
+      integer(psb_ipk_), intent(out)                 :: info
+      integer(psb_ipk_), intent(in), optional        :: idx
+    end subroutine amg_s_poly_smoother_cseti
+  end interface
+
+  interface
+    subroutine amg_s_poly_smoother_csetc(sm,what,val,info,idx)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
+      implicit none
+      class(amg_s_poly_smoother_type), intent(inout) :: sm
+      character(len=*), intent(in)                   :: what
+      character(len=*), intent(in)                   :: val
+      integer(psb_ipk_), intent(out)                 :: info
+      integer(psb_ipk_), intent(in), optional        :: idx
+    end subroutine amg_s_poly_smoother_csetc
+  end interface
+
+  interface
+    subroutine amg_s_poly_smoother_csetr(sm,what,val,info,idx)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
+      implicit none
+      class(amg_s_poly_smoother_type), intent(inout) :: sm
+      character(len=*), intent(in)                   :: what
+      real(psb_spk_), intent(in)                   :: val
+      integer(psb_ipk_), intent(out)                 :: info
+      integer(psb_ipk_), intent(in), optional        :: idx
+    end subroutine amg_s_poly_smoother_csetr
+  end interface
+
+
+contains
+
+
+  subroutine s_poly_smoother_free(sm,info)
+
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_poly_smoother_type), intent(inout) :: sm
+    integer(psb_ipk_), intent(out)                  :: info
+    integer(psb_ipk_) :: err_act
+    character(len=20)  :: name='s_poly_smoother_free'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+
+
+    if (allocated(sm%sv)) then
+      call sm%sv%free(info)
+      if (info == psb_success_) deallocate(sm%sv,stat=info)
+      if (info /= psb_success_) then
+        info = psb_err_alloc_dealloc_
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+    end if
+    if (allocated(sm%poly_beta))  deallocate(sm%poly_beta)
+    sm%pa => null()
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+  end subroutine s_poly_smoother_free
+
+  function s_poly_smoother_sizeof(sm) result(val)
+
+    implicit none
+    ! Arguments
+    class(amg_s_poly_smoother_type), intent(in) :: sm
+    integer(psb_epk_) :: val
+
+    val = psb_sizeof_dp
+    if (allocated(sm%sv)) val = val + sm%sv%sizeof()
+    if (allocated(sm%poly_beta)) val = val + psb_sizeof_dp * size(sm%poly_beta)
+
+    return
+  end function s_poly_smoother_sizeof
+
+  subroutine s_poly_smoother_default(sm)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_s_poly_smoother_type), intent(inout) :: sm
+
+    !
+    ! Default: BJAC with no residual check
+    !
+    sm%pdegree      = 1
+    sm%rho_ba       = -sone
+    sm%variant      = amg_cheb_4_
+    sm%rho_estimate = amg_poly_rho_est_power_
+    sm%rho_estimate_iterations = 20
+    if (allocated(sm%sv)) then
+      call sm%sv%default()
+    end if
+
+    return
+  end subroutine s_poly_smoother_default
+
+  function s_poly_smoother_get_nzeros(sm) result(val)
+
+    implicit none
+    ! Arguments
+    class(amg_s_poly_smoother_type), intent(in) :: sm
+    integer(psb_epk_) :: val
+    integer(psb_ipk_)        :: i
+
+    val = 0
+    if (allocated(sm%sv)) val = val + sm%sv%get_nzeros()
+
+    return
+  end function s_poly_smoother_get_nzeros
+
+  function s_poly_smoother_get_wrksize(sm) result(val)
+    implicit none
+    class(amg_s_poly_smoother_type), intent(inout) :: sm
+    integer(psb_ipk_)  :: val
+
+    val = 4
+    if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
+
+  end function s_poly_smoother_get_wrksize
+
+  function s_poly_smoother_get_fmt() result(val)
+    implicit none
+    character(len=32)  :: val
+
+    val = "Polynomial smoother"
+  end function s_poly_smoother_get_fmt
+
+  function s_poly_smoother_get_id() result(val)
+    implicit none
+    integer(psb_ipk_)  :: val
+
+    val = amg_poly_
+  end function s_poly_smoother_get_id
+
+
+end module amg_s_poly_smoother

amgprec/amg_s_prec_type.f90

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

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_ilu_solver.f90

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

amgprec/amg_z_inner_mod.f90

@@ -109,11 +109,12 @@ module amg_z_inner_mod
   end interface amg_map_to_tprol
 
   abstract interface
-    subroutine amg_zaggrmat_var_bld(a,desc_a,ilaggr,nlaggr,parms,&
+    subroutine amg_zaggrmat_var_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,parms,&
          & ac,desc_ac,op_prol,op_restr,t_prol,info)
       import :: psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_, psb_lzspmat_type
       import ::  amg_z_onelev_type, amg_dml_parms
       implicit none 
+      integer(psb_ipk_), intent(in)               :: dol1smoothing
       type(psb_zspmat_type), intent(in)         :: a
       type(psb_desc_type), intent(inout)          :: desc_a
       integer(psb_lpk_), intent(inout)            :: ilaggr(:), nlaggr(:)

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,585 @@
+!  
+!   
+!                             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()
+    if (allocated(sv%dv)) then
+      call sv%dv%free(info)
+      deallocate(sv%dv)
+    end if
+    if (allocated(sv%d)) deallocate(sv%d)
+
+    call psb_erractionrestore(err_act)
+    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/amg_z_onelev_mod.f90

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

amgprec/amg_z_prec_type.f90

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

amgprec/impl/Makefile

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

amgprec/impl/aggregator/MatchBoxPC.cpp

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

amgprec/impl/aggregator/MatchBoxPC.h

@@ -59,7 +59,11 @@
 #include <assert.h>
 #include <map>
 #include <vector>
+#ifdef OPENMP
+// OpenMP is included and used if and only if the OpenMP version of the matching
+// is required
 #include "omp.h"
+#endif
 #include "primitiveDataTypeDefinitions.h"
 #include "dataStrStaticQueue.h"
 
@@ -78,6 +82,8 @@ const int BundleTag = 9;  // Predefined tag
 
 static vector<MilanLongInt> DEFAULT_VECTOR;
 
+#if !defined(SERIAL_MPI)
+
 // MPI type map
 template <typename T>
 MPI_Datatype TypeMap();
@@ -89,6 +95,7 @@ template <>
 inline MPI_Datatype TypeMap<double>() { return MPI_DOUBLE; }
 template <>
 inline MPI_Datatype TypeMap<float>() { return MPI_FLOAT; }
+#endif
 
 #ifdef __cplusplus
 extern "C"
@@ -174,252 +181,416 @@ extern "C"
 #define MilanRealMin MINUS_INFINITY
 #endif
 
-    // Function of find the owner of a ghost vertex using binary search:
-    MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
-                              MilanInt myRank, MilanInt numProcs);
+/* These functions are only used in the experimental OMP implementation, if that
+is disabled there is no reason to actually compile or reference them. */
 
-    MilanLongInt firstComputeCandidateMate(MilanLongInt adj1,
-                                           MilanLongInt adj2,
-                                           MilanLongInt *verLocInd,
-                                           MilanReal *edgeLocWeight);
+  // Function of find the owner of a ghost vertex using binary search:
+  MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
+			    MilanInt myRank, MilanInt numProcs);
+  
+  MilanLongInt firstComputeCandidateMateD(MilanLongInt adj1,
+					 MilanLongInt adj2,
+					 MilanLongInt *verLocInd,
+					 MilanReal *edgeLocWeight);
 
-    void queuesTransfer(vector<MilanLongInt> &U,
-                        vector<MilanLongInt> &privateU,
-                        vector<MilanLongInt> &QLocalVtx,
-                        vector<MilanLongInt> &QGhostVtx,
-                        vector<MilanLongInt> &QMsgType,
-                        vector<MilanInt> &QOwner,
-                        vector<MilanLongInt> &privateQLocalVtx,
-                        vector<MilanLongInt> &privateQGhostVtx,
-                        vector<MilanLongInt> &privateQMsgType,
-                        vector<MilanInt> &privateQOwner);
+  
+  void queuesTransfer(vector<MilanLongInt> &U,
+		      vector<MilanLongInt> &privateU,
+		      vector<MilanLongInt> &QLocalVtx,
+		      vector<MilanLongInt> &QGhostVtx,
+		      vector<MilanLongInt> &QMsgType,
+		      vector<MilanInt> &QOwner,
+		      vector<MilanLongInt> &privateQLocalVtx,
+		      vector<MilanLongInt> &privateQGhostVtx,
+		      vector<MilanLongInt> &privateQMsgType,
+		      vector<MilanInt> &privateQOwner);
+  
+  bool isAlreadyMatched(MilanLongInt node,
+			MilanLongInt StartIndex,
+			MilanLongInt EndIndex,
+			vector<MilanLongInt> &GMate,
+			MilanLongInt *Mate,
+			map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
+  
+  MilanLongInt computeCandidateMateD(MilanLongInt adj1,
+				    MilanLongInt adj2,
+				    MilanReal *edgeLocWeight,
+				    MilanLongInt k,
+				    MilanLongInt *verLocInd,
+				    MilanLongInt StartIndex,
+				    MilanLongInt EndIndex,
+				    vector<MilanLongInt> &GMate,
+				    MilanLongInt *Mate,
+				    map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
+  
+  void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
+		  MilanLongInt StartIndex, MilanLongInt EndIndex,
+		  MilanLongInt *numGhostEdgesPtr,
+		  MilanLongInt *numGhostVerticesPtr,
+		  MilanLongInt *S,
+		  MilanLongInt *verLocInd,
+		  MilanLongInt *verLocPtr,
+		  map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+		  vector<MilanLongInt> &Counter,
+		  vector<MilanLongInt> &verGhostPtr,
+		  vector<MilanLongInt> &verGhostInd,
+		  vector<MilanLongInt> &tempCounter,
+		  vector<MilanLongInt> &GMate,
+		  vector<MilanLongInt> &Message,
+		  vector<MilanLongInt> &QLocalVtx,
+		  vector<MilanLongInt> &QGhostVtx,
+		  vector<MilanLongInt> &QMsgType,
+		  vector<MilanInt> &QOwner,
+		  MilanLongInt *&candidateMate,
+		  vector<MilanLongInt> &U,
+		  vector<MilanLongInt> &privateU,
+		  vector<MilanLongInt> &privateQLocalVtx,
+		  vector<MilanLongInt> &privateQGhostVtx,
+		  vector<MilanLongInt> &privateQMsgType,
+		  vector<MilanInt> &privateQOwner);
+  
+  void clean(MilanLongInt NLVer,
+	     MilanInt myRank,
+	     MilanLongInt MessageIndex,
+	     vector<MPI_Request> &SRequest,
+	     vector<MPI_Status> &SStatus,
+	     MilanInt BufferSize,
+	     MilanLongInt *Buffer,
+	     MilanLongInt msgActual,
+	     MilanLongInt *msgActualSent,
+	     MilanLongInt msgInd,
+	     MilanLongInt *msgIndSent,
+	     MilanLongInt NumMessagesBundled,
+	     MilanReal *msgPercent);
+  
+  void PARALLEL_COMPUTE_CANDIDATE_MATE_BD(MilanLongInt NLVer,
+					 MilanLongInt *verLocPtr,
+					 MilanLongInt *verLocInd,
+					 MilanInt myRank,
+					 MilanReal *edgeLocWeight,
+					 MilanLongInt *candidateMate);
+  
+  void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(MilanLongInt NLVer,
+					 MilanLongInt *candidateMate,
+					 MilanLongInt *verLocInd,
+					 MilanLongInt *verLocPtr,
+					 MilanLongInt StartIndex,
+					 MilanLongInt EndIndex,
+					 MilanLongInt *Mate,
+					 vector<MilanLongInt> &GMate,
+					 map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+					 MilanReal *edgeLocWeight,
+					 MilanLongInt *myCardPtr,
+					 MilanLongInt *msgIndPtr,
+					 MilanLongInt *NumMessagesBundledPtr,
+					 MilanLongInt *SPtr,
+					 MilanLongInt *verDistance,
+					 MilanLongInt *PCounter,
+					 vector<MilanLongInt> &Counter,
+					 MilanInt myRank,
+					 MilanInt numProcs,
+					 vector<MilanLongInt> &U,
+					 vector<MilanLongInt> &privateU,
+					 vector<MilanLongInt> &QLocalVtx,
+					 vector<MilanLongInt> &QGhostVtx,
+					 vector<MilanLongInt> &QMsgType,
+					 vector<MilanInt> &QOwner,
+					 vector<MilanLongInt> &privateQLocalVtx,
+					 vector<MilanLongInt> &privateQGhostVtx,
+					 vector<MilanLongInt> &privateQMsgType,
+					 vector<MilanInt> &privateQOwner);
+  
+  void PROCESS_CROSS_EDGE(MilanLongInt *edge,
+			  MilanLongInt *SPtr);
+  
+  void processMatchedVerticesD(
+			      MilanLongInt NLVer,
+			      vector<MilanLongInt> &UChunkBeingProcessed,
+			      vector<MilanLongInt> &U,
+			      vector<MilanLongInt> &privateU,
+			      MilanLongInt StartIndex,
+			      MilanLongInt EndIndex,
+			      MilanLongInt *myCardPtr,
+			      MilanLongInt *msgIndPtr,
+			      MilanLongInt *NumMessagesBundledPtr,
+			      MilanLongInt *SPtr,
+			      MilanLongInt *verLocPtr,
+			      MilanLongInt *verLocInd,
+			      MilanLongInt *verDistance,
+			      MilanLongInt *PCounter,
+			      vector<MilanLongInt> &Counter,
+			      MilanInt myRank,
+			      MilanInt numProcs,
+			      MilanLongInt *candidateMate,
+			      vector<MilanLongInt> &GMate,
+			      MilanLongInt *Mate,
+			      map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+			      MilanReal *edgeLocWeight,
+			      vector<MilanLongInt> &QLocalVtx,
+			      vector<MilanLongInt> &QGhostVtx,
+			      vector<MilanLongInt> &QMsgType,
+			      vector<MilanInt> &QOwner,
+			      vector<MilanLongInt> &privateQLocalVtx,
+			      vector<MilanLongInt> &privateQGhostVtx,
+			      vector<MilanLongInt> &privateQMsgType,
+			      vector<MilanInt> &privateQOwner);
+  
+  void processMatchedVerticesAndSendMessagesD(
+					     MilanLongInt NLVer,
+					     vector<MilanLongInt> &UChunkBeingProcessed,
+					     vector<MilanLongInt> &U,
+					     vector<MilanLongInt> &privateU,
+					     MilanLongInt StartIndex,
+					     MilanLongInt EndIndex,
+					     MilanLongInt *myCardPtr,
+					     MilanLongInt *msgIndPtr,
+					     MilanLongInt *NumMessagesBundledPtr,
+					     MilanLongInt *SPtr,
+					     MilanLongInt *verLocPtr,
+					     MilanLongInt *verLocInd,
+					     MilanLongInt *verDistance,
+					     MilanLongInt *PCounter,
+					     vector<MilanLongInt> &Counter,
+					     MilanInt myRank,
+					     MilanInt numProcs,
+					     MilanLongInt *candidateMate,
+					     vector<MilanLongInt> &GMate,
+					     MilanLongInt *Mate,
+					     map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+					     MilanReal *edgeLocWeight,
+					     vector<MilanLongInt> &QLocalVtx,
+					     vector<MilanLongInt> &QGhostVtx,
+					     vector<MilanLongInt> &QMsgType,
+					     vector<MilanInt> &QOwner,
+					     vector<MilanLongInt> &privateQLocalVtx,
+					     vector<MilanLongInt> &privateQGhostVtx,
+					     vector<MilanLongInt> &privateQMsgType,
+					     vector<MilanInt> &privateQOwner,
+					     MPI_Comm comm,
+					     MilanLongInt *msgActual,
+					     vector<MilanLongInt> &Message);
+  
+  void sendBundledMessages(MilanLongInt *numGhostEdgesPtr,
+			   MilanInt *BufferSizePtr,
+			   MilanLongInt *Buffer,
+			   vector<MilanLongInt> &PCumulative,
+			   vector<MilanLongInt> &PMessageBundle,
+			   vector<MilanLongInt> &PSizeInfoMessages,
+			   MilanLongInt *PCounter,
+			   MilanLongInt NumMessagesBundled,
+			   MilanLongInt *msgActualPtr,
+			   MilanLongInt *MessageIndexPtr,
+			   MilanInt numProcs,
+			   MilanInt myRank,
+			   MPI_Comm comm,
+			   vector<MilanLongInt> &QLocalVtx,
+			   vector<MilanLongInt> &QGhostVtx,
+			   vector<MilanLongInt> &QMsgType,
+			   vector<MilanInt> &QOwner,
+			   vector<MPI_Request> &SRequest,
+			   vector<MPI_Status> &SStatus);
+  
+  void processMessagesD(
+		       MilanLongInt NLVer,
+		       MilanLongInt *Mate,
+		       MilanLongInt *candidateMate,
+		       map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+		       vector<MilanLongInt> &GMate,
+		       vector<MilanLongInt> &Counter,
+		       MilanLongInt StartIndex,
+		       MilanLongInt EndIndex,
+		       MilanLongInt *myCardPtr,
+		       MilanLongInt *msgIndPtr,
+		       MilanLongInt *msgActualPtr,
+		       MilanReal *edgeLocWeight,
+		       MilanLongInt *verDistance,
+		       MilanLongInt *verLocPtr,
+		       MilanLongInt k,
+		       MilanLongInt *verLocInd,
+		       MilanInt numProcs,
+		       MilanInt myRank,
+		       MPI_Comm comm,
+		       vector<MilanLongInt> &Message,
+		       MilanLongInt numGhostEdges,
+		       MilanLongInt u,
+		       MilanLongInt v,
+		       MilanLongInt *SPtr,
+		       vector<MilanLongInt> &U);
+  
+  void extractUChunk(
+		     vector<MilanLongInt> &UChunkBeingProcessed,
+		     vector<MilanLongInt> &U,
+		     vector<MilanLongInt> &privateU);
 
-    bool isAlreadyMatched(MilanLongInt node,
-                          MilanLongInt StartIndex,
-                          MilanLongInt EndIndex,
-                          vector<MilanLongInt> &GMate,
-                          MilanLongInt *Mate,
-                          map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
+  MilanLongInt firstComputeCandidateMateS(MilanLongInt adj1,
+					 MilanLongInt adj2,
+					 MilanLongInt *verLocInd,
+					  MilanFloat *edgeLocWeight);
 
-    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);
+  MilanLongInt computeCandidateMateS(MilanLongInt adj1,
+				    MilanLongInt adj2,
+				    MilanFloat *edgeLocWeight,
+				    MilanLongInt k,
+				    MilanLongInt *verLocInd,
+				    MilanLongInt StartIndex,
+				    MilanLongInt EndIndex,
+				    vector<MilanLongInt> &GMate,
+				    MilanLongInt *Mate,
+				    map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
+  
+  void PARALLEL_COMPUTE_CANDIDATE_MATE_BS(MilanLongInt NLVer,
+					 MilanLongInt *verLocPtr,
+					 MilanLongInt *verLocInd,
+					 MilanInt myRank,
+					 MilanFloat *edgeLocWeight,
+					 MilanLongInt *candidateMate);
+  
+  void PARALLEL_PROCESS_EXPOSED_VERTEX_BS(MilanLongInt NLVer,
+					 MilanLongInt *candidateMate,
+					 MilanLongInt *verLocInd,
+					 MilanLongInt *verLocPtr,
+					 MilanLongInt StartIndex,
+					 MilanLongInt EndIndex,
+					 MilanLongInt *Mate,
+					 vector<MilanLongInt> &GMate,
+					 map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+					 MilanFloat *edgeLocWeight,
+					 MilanLongInt *myCardPtr,
+					 MilanLongInt *msgIndPtr,
+					 MilanLongInt *NumMessagesBundledPtr,
+					 MilanLongInt *SPtr,
+					 MilanLongInt *verDistance,
+					 MilanLongInt *PCounter,
+					 vector<MilanLongInt> &Counter,
+					 MilanInt myRank,
+					 MilanInt numProcs,
+					 vector<MilanLongInt> &U,
+					 vector<MilanLongInt> &privateU,
+					 vector<MilanLongInt> &QLocalVtx,
+					 vector<MilanLongInt> &QGhostVtx,
+					 vector<MilanLongInt> &QMsgType,
+					 vector<MilanInt> &QOwner,
+					 vector<MilanLongInt> &privateQLocalVtx,
+					 vector<MilanLongInt> &privateQGhostVtx,
+					 vector<MilanLongInt> &privateQMsgType,
+					 vector<MilanInt> &privateQOwner);
+  void processMatchedVerticesS(
+			      MilanLongInt NLVer,
+			      vector<MilanLongInt> &UChunkBeingProcessed,
+			      vector<MilanLongInt> &U,
+			      vector<MilanLongInt> &privateU,
+			      MilanLongInt StartIndex,
+			      MilanLongInt EndIndex,
+			      MilanLongInt *myCardPtr,
+			      MilanLongInt *msgIndPtr,
+			      MilanLongInt *NumMessagesBundledPtr,
+			      MilanLongInt *SPtr,
+			      MilanLongInt *verLocPtr,
+			      MilanLongInt *verLocInd,
+			      MilanLongInt *verDistance,
+			      MilanLongInt *PCounter,
+			      vector<MilanLongInt> &Counter,
+			      MilanInt myRank,
+			      MilanInt numProcs,
+			      MilanLongInt *candidateMate,
+			      vector<MilanLongInt> &GMate,
+			      MilanLongInt *Mate,
+			      map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+			      MilanFloat *edgeLocWeight,
+			      vector<MilanLongInt> &QLocalVtx,
+			      vector<MilanLongInt> &QGhostVtx,
+			      vector<MilanLongInt> &QMsgType,
+			      vector<MilanInt> &QOwner,
+			      vector<MilanLongInt> &privateQLocalVtx,
+			      vector<MilanLongInt> &privateQGhostVtx,
+			      vector<MilanLongInt> &privateQMsgType,
+			      vector<MilanInt> &privateQOwner);
+  
+  void processMatchedVerticesAndSendMessagesS(
+					     MilanLongInt NLVer,
+					     vector<MilanLongInt> &UChunkBeingProcessed,
+					     vector<MilanLongInt> &U,
+					     vector<MilanLongInt> &privateU,
+					     MilanLongInt StartIndex,
+					     MilanLongInt EndIndex,
+					     MilanLongInt *myCardPtr,
+					     MilanLongInt *msgIndPtr,
+					     MilanLongInt *NumMessagesBundledPtr,
+					     MilanLongInt *SPtr,
+					     MilanLongInt *verLocPtr,
+					     MilanLongInt *verLocInd,
+					     MilanLongInt *verDistance,
+					     MilanLongInt *PCounter,
+					     vector<MilanLongInt> &Counter,
+					     MilanInt myRank,
+					     MilanInt numProcs,
+					     MilanLongInt *candidateMate,
+					     vector<MilanLongInt> &GMate,
+					     MilanLongInt *Mate,
+					     map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+					     MilanFloat *edgeLocWeight,
+					     vector<MilanLongInt> &QLocalVtx,
+					     vector<MilanLongInt> &QGhostVtx,
+					     vector<MilanLongInt> &QMsgType,
+					     vector<MilanInt> &QOwner,
+					     vector<MilanLongInt> &privateQLocalVtx,
+					     vector<MilanLongInt> &privateQGhostVtx,
+					     vector<MilanLongInt> &privateQMsgType,
+					     vector<MilanInt> &privateQOwner,
+					     MPI_Comm comm,
+					     MilanLongInt *msgActual,
+					     vector<MilanLongInt> &Message);
+  
+  void processMessagesS(
+		       MilanLongInt NLVer,
+		       MilanLongInt *Mate,
+		       MilanLongInt *candidateMate,
+		       map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
+		       vector<MilanLongInt> &GMate,
+		       vector<MilanLongInt> &Counter,
+		       MilanLongInt StartIndex,
+		       MilanLongInt EndIndex,
+		       MilanLongInt *myCardPtr,
+		       MilanLongInt *msgIndPtr,
+		       MilanLongInt *msgActualPtr,
+		       MilanFloat *edgeLocWeight,
+		       MilanLongInt *verDistance,
+		       MilanLongInt *verLocPtr,
+		       MilanLongInt k,
+		       MilanLongInt *verLocInd,
+		       MilanInt numProcs,
+		       MilanInt myRank,
+		       MPI_Comm comm,
+		       vector<MilanLongInt> &Message,
+		       MilanLongInt numGhostEdges,
+		       MilanLongInt u,
+		       MilanLongInt v,
+		       MilanLongInt *SPtr,
+		       vector<MilanLongInt> &U);
+  
+  
+  void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
+			 MilanLongInt NLVer, MilanLongInt NLEdge,
+			 MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
+			 MilanLongInt *verDistance,
+			 MilanLongInt *Mate,
+			 MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
+			 MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
+			 MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
+			 MilanLongInt *ph1_card, MilanLongInt *ph2_card);
 
-    void 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 salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
+			 MilanLongInt NLVer, MilanLongInt NLEdge,
+			 MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanFloat *edgeLocWeight,
+			 MilanLongInt *verDistance,
+			 MilanLongInt *Mate,
+			 MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
+			 MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
+			 MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
+			 MilanLongInt *ph1_card, MilanLongInt *ph2_card);
 
-    void 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,

amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.cpp

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

amgprec/impl/aggregator/algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.cpp

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

amgprec/impl/aggregator/amg_c_dec_aggregator_mat_bld.f90

@@ -177,23 +177,24 @@ subroutine  amg_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   select case (parms%aggr_prol)
   case (amg_no_smooth_) 
 
-    call amg_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,&
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_caggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,&
+            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
-  case(amg_smooth_prol_) 
+  case(amg_smooth_prol_,amg_l1_smooth_prol_) 
 
-    call amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_caggrmat_smth_bld(parms%aggr_prol,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,&
+            op_restr,t_prol,info)
 
 !!$  case(amg_biz_prol_) 
 !!$
 !!$    call amg_caggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
 !!$         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
-
+  
   case(amg_min_energy_) 
 
-    call amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_caggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,&
+            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case default
     info = psb_err_internal_error_

amgprec/impl/aggregator/amg_c_soc1_map_bld.F90

@@ -250,7 +250,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
               ! 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
+              if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.czero)) then
                 ip = ip + 1
                 icol(ip) = icol(k)
               end if
@@ -275,7 +275,8 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
             disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
             if (disjoint) then
               locnaggr(kk)     = locnaggr(kk) + 1
-              itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
+              itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
+              itmp = itmp*nths+kk
               if (itmp < (bnds(kk)-1+locnaggr(kk))) then
                 !$omp atomic update
                 info = max(12345678,info)
@@ -356,7 +357,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       do k=1, nz
         j   = icol(k)
         if ((1<=j).and.(j<=nr)) then 
-          if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
+          if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.czero)) then
             ip = ip + 1
             icol(ip) = icol(k)
           end if
@@ -544,4 +545,3 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   return
 
 end subroutine amg_c_soc1_map_bld
-

amgprec/impl/aggregator/amg_c_soc2_map_bld.F90

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

amgprec/impl/aggregator/amg_caggrmat_minnrg_bld.f90

@@ -69,6 +69,7 @@
 !
 !
 ! Arguments:
+!    dol1smoothing - fictitious integer argument, it is not used inside
 !    a          -  type(psb_cspmat_type), input.     
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -104,8 +105,8 @@
 !                  Error code.
 !
 !
-subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_caggrmat_minnrg_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_c_inner_mod, amg_protect_name => amg_caggrmat_minnrg_bld
@@ -113,6 +114,7 @@ subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)                 :: dol1smoothing
   type(psb_cspmat_type), intent(in)           :: a
   type(psb_desc_type), intent(inout)            :: desc_a
   integer(psb_lpk_), intent(inout)              :: ilaggr(:), nlaggr(:)
@@ -171,6 +173,13 @@ subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   filter_mat = (parms%aggr_filter == amg_filter_mat_)
 
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_; 
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
+
+
   !NEEDS TO BE REWORKED !!
   
   ! naggr: number of local aggregates
@@ -300,7 +309,7 @@ subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
 !!$        endif
 !!$      enddo
 !!$      if (jd == -1) then 
-!!$        write(0,*) 'Wrong input: we need the diagonal!!!!', i
+!!$                write(0,*) name,': Warning: there is no diagonal element', i
 !!$      else
 !!$        acsrf%val(jd)=acsrf%val(jd)-tmp
 !!$      end if

amgprec/impl/aggregator/amg_caggrmat_nosmth_bld.f90

@@ -94,10 +94,11 @@
 !               
 !    info       -  integer, output.
 !                  Error code.
+!    dol1smoothing - optional, this is here just for interfacing reasons. It is not used by the
+!                    code
 !
-!
-subroutine amg_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_caggrmat_nosmth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_c_inner_mod, amg_protect_name => amg_caggrmat_nosmth_bld
@@ -105,6 +106,7 @@ subroutine amg_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)              :: dol1smoothing 
   type(psb_cspmat_type), intent(in)        :: a
   type(psb_desc_type), intent(inout)         :: desc_a
   integer(psb_lpk_), intent(inout)           :: ilaggr(:), nlaggr(:)
@@ -137,6 +139,12 @@ subroutine amg_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   ctxt = desc_a%get_context()
   call psb_info(ctxt, me, np)
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_;         
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
+
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
   ncol  = desc_a%get_local_cols()

amgprec/impl/aggregator/amg_caggrmat_smth_bld.f90

@@ -69,6 +69,8 @@
 !
 !
 ! Arguments:
+!    dol1smooth -  Integer taking the type of smoother that has to be used
+!                  on the tentative prolongator
 !    a          -  type(psb_cspmat_type), input.     
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -102,8 +104,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_c_inner_mod, amg_protect_name => amg_caggrmat_smth_bld
@@ -112,6 +114,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)            :: dol1smoothing
   type(psb_cspmat_type), intent(in)      :: a
   type(psb_desc_type), intent(inout)       :: desc_a
   integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
@@ -132,7 +135,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   type(psb_c_coo_sparse_mat) :: coo_prol, coo_restr
   type(psb_c_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
   complex(psb_spk_), allocatable :: adiag(:)
-  real(psb_spk_), allocatable :: arwsum(:)
+  real(psb_spk_), allocatable :: arwsum(:),l1rwsum(:)
   integer(psb_ipk_)  :: ierr(5)
   logical            :: filter_mat
   integer(psb_ipk_)            :: debug_level, debug_unit, err_act
@@ -141,6 +144,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   logical, parameter :: debug_new=.false.
   character(len=80) :: filename
   logical, parameter :: do_timings=.false.
+  logical :: do_l1correction=.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
 
@@ -173,6 +177,9 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if ((do_timings).and.(idx_ptap==-1)) &
        & idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld  ")
 
+  ! check if we have to use Jacobi or l1-Jacobi to smooth the tentative prolongator
+  if (dol1smoothing.eq.amg_l1_smooth_prol_) do_l1correction=.true.
+
 
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
@@ -200,6 +207,24 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
+  !
+  ! Do the l1-correction on the diagonal if it is requested
+  !
+  if (do_l1correction) then
+    allocate(l1rwsum(nrow))
+    call acsr%arwsum(l1rwsum)
+    if (info == psb_success_) &
+      & call psb_realloc(ncol,l1rwsum,info)
+    if (info == psb_success_) &
+      & call psb_halo(l1rwsum,desc_a,info)
+    ! \tilde{D}_{i,i} = \sum_{j \ne i} |a_{i,j}|
+    !$OMP parallel do private(i) schedule(static)
+    do i=1,size(adiag)
+      adiag(i) = adiag(i) + l1rwsum(i) - abs(adiag(i))
+    end do
+    !$OMP end parallel do
+  end if
+
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -230,6 +255,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
       enddo
       if (jd == -1) then 
+        ! if (.not.do_l1correction) 
         write(0,*) 'Wrong input: we need the diagonal!!!!', i
       else
         acsrf%val(jd)=acsrf%val(jd)-tmp
@@ -252,6 +278,10 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   !$OMP end parallel do 
   if (parms%aggr_omega_alg == amg_eig_est_) then 
 
+    !if (do_l1correction) then
+    !  ! For l1-Jacobi this can be estimated with 1
+    !  parms%aggr_omega_val = done
+    !
     if (parms%aggr_eig == amg_max_norm_) then 
       allocate(arwsum(nrow))
       call acsr%arwsum(arwsum)      
@@ -259,7 +289,6 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
       call psb_amx(ctxt,anorm)
       omega = 4.d0/(3.d0*anorm)
       parms%aggr_omega_val = omega 
-
     else 
       info = psb_err_internal_error_
       call psb_errpush(info,name,a_err='invalid amg_aggr_eig_')
@@ -322,6 +351,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done smooth_aggregate '
+  if (allocated(l1rwsum)) deallocate(l1rwsum)
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_d_dec_aggregator_mat_bld.f90

@@ -177,23 +177,24 @@ subroutine  amg_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   select case (parms%aggr_prol)
   case (amg_no_smooth_) 
 
-    call amg_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,&
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_daggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,&
+            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
-  case(amg_smooth_prol_) 
+  case(amg_smooth_prol_,amg_l1_smooth_prol_) 
 
-    call amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_daggrmat_smth_bld(parms%aggr_prol,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,&
+            op_restr,t_prol,info)
 
 !!$  case(amg_biz_prol_) 
 !!$
 !!$    call amg_daggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
 !!$         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
-
+  
   case(amg_min_energy_) 
 
-    call amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_daggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,&
+            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case default
     info = psb_err_internal_error_

amgprec/impl/aggregator/amg_d_parmatch_aggregator_mat_bld.F90

@@ -184,20 +184,23 @@ subroutine  amg_d_parmatch_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   !
   select case (parms%aggr_prol)
   case (amg_no_smooth_)
-    call amg_d_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
-         & ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_d_parmatch_unsmth_bld(parms%aggr_prol,ag,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,op_restr,&
+            t_prol,info)
 
-  case(amg_smooth_prol_)
-    call amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
-         & ac,desc_ac,op_prol,op_restr,t_prol,info)
+  case(amg_smooth_prol_,amg_l1_smooth_prol_)
+    call amg_d_parmatch_smth_bld(parms%aggr_prol,ag,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,op_restr,&
+            t_prol,info)
 
 !!$  case(amg_biz_prol_)
 !!$    call amg_daggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
 !!$         & parms,ac,desc_ac,op_prol,op_restr,info)
 
   case(amg_min_energy_)
-    call amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_daggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,op_restr,&
+            t_prol,info)
 
   case default
     info = psb_err_internal_error_

amgprec/impl/aggregator/amg_d_parmatch_smth_bld.F90

@@ -69,6 +69,8 @@
 !
 !
 ! Arguments:
+!    dol1smoothing - Select between l1-Jacobi and Jacobi as smoother for the
+!                  tentative prolongator
 !    a          -  type(psb_dspmat_type), input.
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -102,8 +104,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_d_parmatch_smth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_d_inner_mod
@@ -116,6 +118,7 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)            :: dol1smoothing
   class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
   type(psb_dspmat_type), intent(in)      :: a
   type(psb_desc_type), intent(inout)     :: desc_a
@@ -137,7 +140,7 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   type(psb_d_coo_sparse_mat)  :: coo_prol, coo_restr
   type(psb_d_csr_sparse_mat)  :: acsrf, csr_prol, acsr, tcsr
   real(psb_dpk_), allocatable :: adiag(:)
-  real(psb_dpk_), allocatable :: arwsum(:)
+  real(psb_dpk_), allocatable :: arwsum(:),l1rwsum(:)
   logical            :: filter_mat
   integer(psb_ipk_)            :: debug_level, debug_unit, err_act
   integer(psb_ipk_), parameter :: ncmax=16
@@ -145,6 +148,7 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   logical, parameter :: debug_new=.false., dump_r=.false., dump_p=.false., debug=.false.
   character(len=80) :: filename
   logical, parameter :: do_timings=.false.
+  logical :: do_l1correction=.false.
   integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1, idx_phase3=-1
   integer(psb_ipk_), save :: idx_cdasb=-1, idx_ptap=-1
 
@@ -166,6 +170,10 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   ncol  = desc_a%get_local_cols()
 
   theta = parms%aggr_thresh
+  ! Check if we have to perform l1-Jacobi or Jacobi as smoother
+  if(dol1smoothing.eq.amg_l1_smooth_prol_) do_l1correction=.true.
+
+
   !write(0,*) me,' ',trim(name),' Start ',idx_spspmm
   if ((do_timings).and.(idx_spspmm==-1)) &
        & idx_spspmm = psb_get_timer_idx("PMC_SMTH_BLD: par_spspmm")
@@ -217,6 +225,19 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
+  ! Get the l1-diagonal of D
+  if (do_l1correction) then
+    allocate(l1rwsum(nrow))
+    call acsr%arwsum(l1rwsum)
+    if (info == psb_success_) &
+      & call psb_realloc(ncol,l1rwsum,info)
+    if (info == psb_success_) &
+      & call psb_halo(l1rwsum,desc_a,info)
+    ! \tilde{D}_{i,i} = \sum_{j \ne i} |a_{i,j}|
+    do i=1,size(adiag)
+      adiag(i) = adiag(i) + l1rwsum(i) - abs(adiag(i))
+    end do
+  end if
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -246,7 +267,7 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
 
       enddo
       if (jd == -1) then
-        write(0,*) 'Wrong input: we need the diagonal!!!!', i
+        write(0,*) name,': Warning: there is no diagonal element', i
       else
         acsrf%val(jd)=acsrf%val(jd)-tmp
       end if
@@ -267,7 +288,10 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
 
   if (parms%aggr_omega_alg == amg_eig_est_) then
 
-    if (parms%aggr_eig == amg_max_norm_) then
+    if (do_l1correction) then
+      ! For l1-Jacobi this can be estimated with 1
+      parms%aggr_omega_val = done
+    else if (parms%aggr_eig == amg_max_norm_) then
       allocate(arwsum(nrow))
       call acsr%arwsum(arwsum)
       anorm = maxval(abs(adiag(1:nrow)*arwsum(1:nrow)))
@@ -373,6 +397,7 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
 
     end block
   end if
+  if (allocated(l1rwsum)) deallocate(l1rwsum)
   if (do_timings) call psb_toc(idx_phase2)
 
   if (debug_level >= psb_debug_outer_) &

amgprec/impl/aggregator/amg_d_parmatch_unsmth_bld.F90

@@ -68,6 +68,8 @@
 !
 !
 ! Arguments:
+!    dol1smoothing - this not actually used inside unsmoothed aggregation, it
+!                  is used just to perform a check
 !    a          -  type(psb_dspmat_type), input.
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -101,8 +103,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine amg_d_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_d_parmatch_unsmth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_d_inner_mod
@@ -115,6 +117,7 @@ subroutine amg_d_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in) :: dol1smoothing
   class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
   type(psb_dspmat_type), intent(in)      :: a
   type(psb_desc_type), intent(inout)     :: desc_a
@@ -159,6 +162,11 @@ subroutine amg_d_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   ictxt = desc_a%get_context()
 
   call psb_info(ictxt, me, np)
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_;         
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
 
 #if !defined(SERIAL_MPI)
   nglob = desc_a%get_global_rows()

amgprec/impl/aggregator/amg_d_soc1_map_bld.F90

@@ -250,7 +250,7 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
               ! 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
+              if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.dzero)) then
                 ip = ip + 1
                 icol(ip) = icol(k)
               end if
@@ -275,7 +275,8 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
             disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
             if (disjoint) then
               locnaggr(kk)     = locnaggr(kk) + 1
-              itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
+              itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
+              itmp = itmp*nths+kk
               if (itmp < (bnds(kk)-1+locnaggr(kk))) then
                 !$omp atomic update
                 info = max(12345678,info)
@@ -356,7 +357,7 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       do k=1, nz
         j   = icol(k)
         if ((1<=j).and.(j<=nr)) then 
-          if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
+          if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.dzero)) then
             ip = ip + 1
             icol(ip) = icol(k)
           end if
@@ -544,4 +545,3 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   return
 
 end subroutine amg_d_soc1_map_bld
-

amgprec/impl/aggregator/amg_d_soc2_map_bld.F90

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

amgprec/impl/aggregator/amg_daggrmat_minnrg_bld.f90

@@ -69,6 +69,7 @@
 !
 !
 ! Arguments:
+!    dol1smoothing - fictitious integer argument, it is not used inside
 !    a          -  type(psb_dspmat_type), input.     
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -104,8 +105,8 @@
 !                  Error code.
 !
 !
-subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_daggrmat_minnrg_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_d_inner_mod, amg_protect_name => amg_daggrmat_minnrg_bld
@@ -113,6 +114,7 @@ subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)                 :: dol1smoothing
   type(psb_dspmat_type), intent(in)           :: a
   type(psb_desc_type), intent(inout)            :: desc_a
   integer(psb_lpk_), intent(inout)              :: ilaggr(:), nlaggr(:)
@@ -171,6 +173,13 @@ subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   filter_mat = (parms%aggr_filter == amg_filter_mat_)
 
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_; 
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
+
+
   !NEEDS TO BE REWORKED !!
   
   ! naggr: number of local aggregates
@@ -300,7 +309,7 @@ subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
 !!$        endif
 !!$      enddo
 !!$      if (jd == -1) then 
-!!$        write(0,*) 'Wrong input: we need the diagonal!!!!', i
+!!$                write(0,*) name,': Warning: there is no diagonal element', i
 !!$      else
 !!$        acsrf%val(jd)=acsrf%val(jd)-tmp
 !!$      end if

amgprec/impl/aggregator/amg_daggrmat_nosmth_bld.f90

@@ -94,10 +94,11 @@
 !               
 !    info       -  integer, output.
 !                  Error code.
+!    dol1smoothing - optional, this is here just for interfacing reasons. It is not used by the
+!                    code
 !
-!
-subroutine amg_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_daggrmat_nosmth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_d_inner_mod, amg_protect_name => amg_daggrmat_nosmth_bld
@@ -105,6 +106,7 @@ subroutine amg_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)              :: dol1smoothing 
   type(psb_dspmat_type), intent(in)        :: a
   type(psb_desc_type), intent(inout)         :: desc_a
   integer(psb_lpk_), intent(inout)           :: ilaggr(:), nlaggr(:)
@@ -137,6 +139,12 @@ subroutine amg_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   ctxt = desc_a%get_context()
   call psb_info(ctxt, me, np)
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_;         
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
+
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
   ncol  = desc_a%get_local_cols()

amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90

@@ -69,6 +69,8 @@
 !
 !
 ! Arguments:
+!    dol1smooth -  Integer taking the type of smoother that has to be used
+!                  on the tentative prolongator
 !    a          -  type(psb_dspmat_type), input.     
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -102,8 +104,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_daggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_d_inner_mod, amg_protect_name => amg_daggrmat_smth_bld
@@ -112,6 +114,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)            :: dol1smoothing
   type(psb_dspmat_type), intent(in)      :: a
   type(psb_desc_type), intent(inout)       :: desc_a
   integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
@@ -132,7 +135,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   type(psb_d_coo_sparse_mat) :: coo_prol, coo_restr
   type(psb_d_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
   real(psb_dpk_), allocatable :: adiag(:)
-  real(psb_dpk_), allocatable :: arwsum(:)
+  real(psb_dpk_), allocatable :: arwsum(:),l1rwsum(:)
   integer(psb_ipk_)  :: ierr(5)
   logical            :: filter_mat
   integer(psb_ipk_)            :: debug_level, debug_unit, err_act
@@ -141,6 +144,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   logical, parameter :: debug_new=.false.
   character(len=80) :: filename
   logical, parameter :: do_timings=.false.
+  logical :: do_l1correction=.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
 
@@ -173,6 +177,9 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if ((do_timings).and.(idx_ptap==-1)) &
        & idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld  ")
 
+  ! check if we have to use Jacobi or l1-Jacobi to smooth the tentative prolongator
+  if (dol1smoothing.eq.amg_l1_smooth_prol_) do_l1correction=.true.
+
 
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
@@ -200,6 +207,24 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
+  !
+  ! Do the l1-correction on the diagonal if it is requested
+  !
+  if (do_l1correction) then
+    allocate(l1rwsum(nrow))
+    call acsr%arwsum(l1rwsum)
+    if (info == psb_success_) &
+      & call psb_realloc(ncol,l1rwsum,info)
+    if (info == psb_success_) &
+      & call psb_halo(l1rwsum,desc_a,info)
+    ! \tilde{D}_{i,i} = \sum_{j \ne i} |a_{i,j}|
+    !$OMP parallel do private(i) schedule(static)
+    do i=1,size(adiag)
+      adiag(i) = adiag(i) + l1rwsum(i) - abs(adiag(i))
+    end do
+    !$OMP end parallel do
+  end if
+
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -230,6 +255,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
       enddo
       if (jd == -1) then 
+        ! if (.not.do_l1correction) 
         write(0,*) 'Wrong input: we need the diagonal!!!!', i
       else
         acsrf%val(jd)=acsrf%val(jd)-tmp
@@ -252,6 +278,10 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   !$OMP end parallel do 
   if (parms%aggr_omega_alg == amg_eig_est_) then 
 
+    !if (do_l1correction) then
+    !  ! For l1-Jacobi this can be estimated with 1
+    !  parms%aggr_omega_val = done
+    !
     if (parms%aggr_eig == amg_max_norm_) then 
       allocate(arwsum(nrow))
       call acsr%arwsum(arwsum)      
@@ -259,7 +289,6 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
       call psb_amx(ctxt,anorm)
       omega = 4.d0/(3.d0*anorm)
       parms%aggr_omega_val = omega 
-
     else 
       info = psb_err_internal_error_
       call psb_errpush(info,name,a_err='invalid amg_aggr_eig_')
@@ -322,6 +351,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done smooth_aggregate '
+  if (allocated(l1rwsum)) deallocate(l1rwsum)
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_s_dec_aggregator_mat_bld.f90

@@ -177,23 +177,24 @@ subroutine  amg_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   select case (parms%aggr_prol)
   case (amg_no_smooth_) 
 
-    call amg_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,&
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_saggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,&
+            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
-  case(amg_smooth_prol_) 
+  case(amg_smooth_prol_,amg_l1_smooth_prol_) 
 
-    call amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_saggrmat_smth_bld(parms%aggr_prol,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,&
+            op_restr,t_prol,info)
 
 !!$  case(amg_biz_prol_) 
 !!$
 !!$    call amg_saggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
 !!$         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
-
+  
   case(amg_min_energy_) 
 
-    call amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_saggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,&
+            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case default
     info = psb_err_internal_error_

amgprec/impl/aggregator/amg_s_parmatch_aggregator_mat_bld.F90

@@ -184,20 +184,23 @@ subroutine  amg_s_parmatch_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   !
   select case (parms%aggr_prol)
   case (amg_no_smooth_)
-    call amg_s_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
-         & ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_s_parmatch_unsmth_bld(parms%aggr_prol,ag,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,op_restr,&
+            t_prol,info)
 
-  case(amg_smooth_prol_)
-    call amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
-         & ac,desc_ac,op_prol,op_restr,t_prol,info)
+  case(amg_smooth_prol_,amg_l1_smooth_prol_)
+    call amg_s_parmatch_smth_bld(parms%aggr_prol,ag,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,op_restr,&
+            t_prol,info)
 
 !!$  case(amg_biz_prol_)
 !!$    call amg_saggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
 !!$         & parms,ac,desc_ac,op_prol,op_restr,info)
 
   case(amg_min_energy_)
-    call amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_saggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,op_restr,&
+            t_prol,info)
 
   case default
     info = psb_err_internal_error_

amgprec/impl/aggregator/amg_s_parmatch_smth_bld.F90

@@ -69,6 +69,8 @@
 !
 !
 ! Arguments:
+!    dol1smoothing - Select between l1-Jacobi and Jacobi as smoother for the
+!                  tentative prolongator
 !    a          -  type(psb_sspmat_type), input.
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -102,8 +104,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_s_parmatch_smth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_s_inner_mod
@@ -116,6 +118,7 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)            :: dol1smoothing
   class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
   type(psb_sspmat_type), intent(in)      :: a
   type(psb_desc_type), intent(inout)     :: desc_a
@@ -137,7 +140,7 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   type(psb_s_coo_sparse_mat)  :: coo_prol, coo_restr
   type(psb_s_csr_sparse_mat)  :: acsrf, csr_prol, acsr, tcsr
   real(psb_spk_), allocatable :: adiag(:)
-  real(psb_spk_), allocatable :: arwsum(:)
+  real(psb_spk_), allocatable :: arwsum(:),l1rwsum(:)
   logical            :: filter_mat
   integer(psb_ipk_)            :: debug_level, debug_unit, err_act
   integer(psb_ipk_), parameter :: ncmax=16
@@ -145,6 +148,7 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   logical, parameter :: debug_new=.false., dump_r=.false., dump_p=.false., debug=.false.
   character(len=80) :: filename
   logical, parameter :: do_timings=.false.
+  logical :: do_l1correction=.false.
   integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1, idx_phase3=-1
   integer(psb_ipk_), save :: idx_cdasb=-1, idx_ptap=-1
 
@@ -166,6 +170,10 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   ncol  = desc_a%get_local_cols()
 
   theta = parms%aggr_thresh
+  ! Check if we have to perform l1-Jacobi or Jacobi as smoother
+  if(dol1smoothing.eq.amg_l1_smooth_prol_) do_l1correction=.true.
+
+
   !write(0,*) me,' ',trim(name),' Start ',idx_spspmm
   if ((do_timings).and.(idx_spspmm==-1)) &
        & idx_spspmm = psb_get_timer_idx("PMC_SMTH_BLD: par_spspmm")
@@ -217,6 +225,19 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
+  ! Get the l1-diagonal of D
+  if (do_l1correction) then
+    allocate(l1rwsum(nrow))
+    call acsr%arwsum(l1rwsum)
+    if (info == psb_success_) &
+      & call psb_realloc(ncol,l1rwsum,info)
+    if (info == psb_success_) &
+      & call psb_halo(l1rwsum,desc_a,info)
+    ! \tilde{D}_{i,i} = \sum_{j \ne i} |a_{i,j}|
+    do i=1,size(adiag)
+      adiag(i) = adiag(i) + l1rwsum(i) - abs(adiag(i))
+    end do
+  end if
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -246,7 +267,7 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
 
       enddo
       if (jd == -1) then
-        write(0,*) 'Wrong input: we need the diagonal!!!!', i
+        write(0,*) name,': Warning: there is no diagonal element', i
       else
         acsrf%val(jd)=acsrf%val(jd)-tmp
       end if
@@ -267,7 +288,10 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
 
   if (parms%aggr_omega_alg == amg_eig_est_) then
 
-    if (parms%aggr_eig == amg_max_norm_) then
+    if (do_l1correction) then
+      ! For l1-Jacobi this can be estimated with 1
+      parms%aggr_omega_val = done
+    else if (parms%aggr_eig == amg_max_norm_) then
       allocate(arwsum(nrow))
       call acsr%arwsum(arwsum)
       anorm = maxval(abs(adiag(1:nrow)*arwsum(1:nrow)))
@@ -373,6 +397,7 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
 
     end block
   end if
+  if (allocated(l1rwsum)) deallocate(l1rwsum)
   if (do_timings) call psb_toc(idx_phase2)
 
   if (debug_level >= psb_debug_outer_) &

amgprec/impl/aggregator/amg_s_parmatch_unsmth_bld.F90

@@ -68,6 +68,8 @@
 !
 !
 ! Arguments:
+!    dol1smoothing - this not actually used inside unsmoothed aggregation, it
+!                  is used just to perform a check
 !    a          -  type(psb_sspmat_type), input.
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -101,8 +103,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine amg_s_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_s_parmatch_unsmth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_s_inner_mod
@@ -115,6 +117,7 @@ subroutine amg_s_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in) :: dol1smoothing
   class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
   type(psb_sspmat_type), intent(in)      :: a
   type(psb_desc_type), intent(inout)     :: desc_a
@@ -159,6 +162,11 @@ subroutine amg_s_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
   ictxt = desc_a%get_context()
 
   call psb_info(ictxt, me, np)
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_;         
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
 
 #if !defined(SERIAL_MPI)
   nglob = desc_a%get_global_rows()

amgprec/impl/aggregator/amg_s_soc1_map_bld.F90

@@ -250,7 +250,7 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
               ! 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
+              if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.szero)) then
                 ip = ip + 1
                 icol(ip) = icol(k)
               end if
@@ -275,7 +275,8 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
             disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
             if (disjoint) then
               locnaggr(kk)     = locnaggr(kk) + 1
-              itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
+              itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
+              itmp = itmp*nths+kk
               if (itmp < (bnds(kk)-1+locnaggr(kk))) then
                 !$omp atomic update
                 info = max(12345678,info)
@@ -356,7 +357,7 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       do k=1, nz
         j   = icol(k)
         if ((1<=j).and.(j<=nr)) then 
-          if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
+          if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.szero)) then
             ip = ip + 1
             icol(ip) = icol(k)
           end if
@@ -544,4 +545,3 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   return
 
 end subroutine amg_s_soc1_map_bld
-

amgprec/impl/aggregator/amg_s_soc2_map_bld.F90

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

amgprec/impl/aggregator/amg_saggrmat_minnrg_bld.f90

@@ -69,6 +69,7 @@
 !
 !
 ! Arguments:
+!    dol1smoothing - fictitious integer argument, it is not used inside
 !    a          -  type(psb_sspmat_type), input.     
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -104,8 +105,8 @@
 !                  Error code.
 !
 !
-subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_saggrmat_minnrg_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_s_inner_mod, amg_protect_name => amg_saggrmat_minnrg_bld
@@ -113,6 +114,7 @@ subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)                 :: dol1smoothing
   type(psb_sspmat_type), intent(in)           :: a
   type(psb_desc_type), intent(inout)            :: desc_a
   integer(psb_lpk_), intent(inout)              :: ilaggr(:), nlaggr(:)
@@ -171,6 +173,13 @@ subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   filter_mat = (parms%aggr_filter == amg_filter_mat_)
 
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_; 
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
+
+
   !NEEDS TO BE REWORKED !!
   
   ! naggr: number of local aggregates
@@ -300,7 +309,7 @@ subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
 !!$        endif
 !!$      enddo
 !!$      if (jd == -1) then 
-!!$        write(0,*) 'Wrong input: we need the diagonal!!!!', i
+!!$                write(0,*) name,': Warning: there is no diagonal element', i
 !!$      else
 !!$        acsrf%val(jd)=acsrf%val(jd)-tmp
 !!$      end if

amgprec/impl/aggregator/amg_saggrmat_nosmth_bld.f90

@@ -94,10 +94,11 @@
 !               
 !    info       -  integer, output.
 !                  Error code.
+!    dol1smoothing - optional, this is here just for interfacing reasons. It is not used by the
+!                    code
 !
-!
-subroutine amg_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_saggrmat_nosmth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_s_inner_mod, amg_protect_name => amg_saggrmat_nosmth_bld
@@ -105,6 +106,7 @@ subroutine amg_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)              :: dol1smoothing 
   type(psb_sspmat_type), intent(in)        :: a
   type(psb_desc_type), intent(inout)         :: desc_a
   integer(psb_lpk_), intent(inout)           :: ilaggr(:), nlaggr(:)
@@ -137,6 +139,12 @@ subroutine amg_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   ctxt = desc_a%get_context()
   call psb_info(ctxt, me, np)
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_;         
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
+
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
   ncol  = desc_a%get_local_cols()

amgprec/impl/aggregator/amg_saggrmat_smth_bld.f90

@@ -69,6 +69,8 @@
 !
 !
 ! Arguments:
+!    dol1smooth -  Integer taking the type of smoother that has to be used
+!                  on the tentative prolongator
 !    a          -  type(psb_sspmat_type), input.     
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -102,8 +104,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_saggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_s_inner_mod, amg_protect_name => amg_saggrmat_smth_bld
@@ -112,6 +114,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)            :: dol1smoothing
   type(psb_sspmat_type), intent(in)      :: a
   type(psb_desc_type), intent(inout)       :: desc_a
   integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
@@ -132,7 +135,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   type(psb_s_coo_sparse_mat) :: coo_prol, coo_restr
   type(psb_s_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
   real(psb_spk_), allocatable :: adiag(:)
-  real(psb_spk_), allocatable :: arwsum(:)
+  real(psb_spk_), allocatable :: arwsum(:),l1rwsum(:)
   integer(psb_ipk_)  :: ierr(5)
   logical            :: filter_mat
   integer(psb_ipk_)            :: debug_level, debug_unit, err_act
@@ -141,6 +144,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   logical, parameter :: debug_new=.false.
   character(len=80) :: filename
   logical, parameter :: do_timings=.false.
+  logical :: do_l1correction=.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
 
@@ -173,6 +177,9 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if ((do_timings).and.(idx_ptap==-1)) &
        & idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld  ")
 
+  ! check if we have to use Jacobi or l1-Jacobi to smooth the tentative prolongator
+  if (dol1smoothing.eq.amg_l1_smooth_prol_) do_l1correction=.true.
+
 
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
@@ -200,6 +207,24 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
+  !
+  ! Do the l1-correction on the diagonal if it is requested
+  !
+  if (do_l1correction) then
+    allocate(l1rwsum(nrow))
+    call acsr%arwsum(l1rwsum)
+    if (info == psb_success_) &
+      & call psb_realloc(ncol,l1rwsum,info)
+    if (info == psb_success_) &
+      & call psb_halo(l1rwsum,desc_a,info)
+    ! \tilde{D}_{i,i} = \sum_{j \ne i} |a_{i,j}|
+    !$OMP parallel do private(i) schedule(static)
+    do i=1,size(adiag)
+      adiag(i) = adiag(i) + l1rwsum(i) - abs(adiag(i))
+    end do
+    !$OMP end parallel do
+  end if
+
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -230,6 +255,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
       enddo
       if (jd == -1) then 
+        ! if (.not.do_l1correction) 
         write(0,*) 'Wrong input: we need the diagonal!!!!', i
       else
         acsrf%val(jd)=acsrf%val(jd)-tmp
@@ -252,6 +278,10 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   !$OMP end parallel do 
   if (parms%aggr_omega_alg == amg_eig_est_) then 
 
+    !if (do_l1correction) then
+    !  ! For l1-Jacobi this can be estimated with 1
+    !  parms%aggr_omega_val = done
+    !
     if (parms%aggr_eig == amg_max_norm_) then 
       allocate(arwsum(nrow))
       call acsr%arwsum(arwsum)      
@@ -259,7 +289,6 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
       call psb_amx(ctxt,anorm)
       omega = 4.d0/(3.d0*anorm)
       parms%aggr_omega_val = omega 
-
     else 
       info = psb_err_internal_error_
       call psb_errpush(info,name,a_err='invalid amg_aggr_eig_')
@@ -322,6 +351,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done smooth_aggregate '
+  if (allocated(l1rwsum)) deallocate(l1rwsum)
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_z_dec_aggregator_mat_bld.f90

@@ -177,23 +177,24 @@ subroutine  amg_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   select case (parms%aggr_prol)
   case (amg_no_smooth_) 
 
-    call amg_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,&
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_zaggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,&
+            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
-  case(amg_smooth_prol_) 
+  case(amg_smooth_prol_,amg_l1_smooth_prol_) 
 
-    call amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_zaggrmat_smth_bld(parms%aggr_prol,a,desc_a,&
+            ilaggr,nlaggr,parms,ac,desc_ac,op_prol,&
+            op_restr,t_prol,info)
 
 !!$  case(amg_biz_prol_) 
 !!$
 !!$    call amg_zaggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
 !!$         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
-
+  
   case(amg_min_energy_) 
 
-    call amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    call amg_zaggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,&
+            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case default
     info = psb_err_internal_error_

amgprec/impl/aggregator/amg_z_soc1_map_bld.F90

@@ -250,7 +250,7 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
               ! 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
+              if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.zzero)) then
                 ip = ip + 1
                 icol(ip) = icol(k)
               end if
@@ -275,7 +275,8 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
             disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
             if (disjoint) then
               locnaggr(kk)     = locnaggr(kk) + 1
-              itmp = (bnds(kk)-1+locnaggr(kk))*nths+kk
+              itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
+              itmp = itmp*nths+kk
               if (itmp < (bnds(kk)-1+locnaggr(kk))) then
                 !$omp atomic update
                 info = max(12345678,info)
@@ -356,7 +357,7 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
       do k=1, nz
         j   = icol(k)
         if ((1<=j).and.(j<=nr)) then 
-          if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
+          if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.zzero)) then
             ip = ip + 1
             icol(ip) = icol(k)
           end if
@@ -544,4 +545,3 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
   return
 
 end subroutine amg_z_soc1_map_bld
-

amgprec/impl/aggregator/amg_z_soc2_map_bld.F90

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

amgprec/impl/aggregator/amg_zaggrmat_minnrg_bld.f90

@@ -69,6 +69,7 @@
 !
 !
 ! Arguments:
+!    dol1smoothing - fictitious integer argument, it is not used inside
 !    a          -  type(psb_zspmat_type), input.     
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -104,8 +105,8 @@
 !                  Error code.
 !
 !
-subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_zaggrmat_minnrg_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_z_inner_mod, amg_protect_name => amg_zaggrmat_minnrg_bld
@@ -113,6 +114,7 @@ subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)                 :: dol1smoothing
   type(psb_zspmat_type), intent(in)           :: a
   type(psb_desc_type), intent(inout)            :: desc_a
   integer(psb_lpk_), intent(inout)              :: ilaggr(:), nlaggr(:)
@@ -171,6 +173,13 @@ subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   filter_mat = (parms%aggr_filter == amg_filter_mat_)
 
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_; 
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
+
+
   !NEEDS TO BE REWORKED !!
   
   ! naggr: number of local aggregates
@@ -300,7 +309,7 @@ subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
 !!$        endif
 !!$      enddo
 !!$      if (jd == -1) then 
-!!$        write(0,*) 'Wrong input: we need the diagonal!!!!', i
+!!$                write(0,*) name,': Warning: there is no diagonal element', i
 !!$      else
 !!$        acsrf%val(jd)=acsrf%val(jd)-tmp
 !!$      end if

amgprec/impl/aggregator/amg_zaggrmat_nosmth_bld.f90

@@ -94,10 +94,11 @@
 !               
 !    info       -  integer, output.
 !                  Error code.
+!    dol1smoothing - optional, this is here just for interfacing reasons. It is not used by the
+!                    code
 !
-!
-subroutine amg_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_zaggrmat_nosmth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_z_inner_mod, amg_protect_name => amg_zaggrmat_nosmth_bld
@@ -105,6 +106,7 @@ subroutine amg_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)              :: dol1smoothing 
   type(psb_zspmat_type), intent(in)        :: a
   type(psb_desc_type), intent(inout)         :: desc_a
   integer(psb_lpk_), intent(inout)           :: ilaggr(:), nlaggr(:)
@@ -137,6 +139,12 @@ subroutine amg_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
   ctxt = desc_a%get_context()
   call psb_info(ctxt, me, np)
+  if (dol1smoothing.ne.amg_no_smooth_) then
+    info=psb_err_fatal_;         
+    call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
+    goto 9999
+  end if
+
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
   ncol  = desc_a%get_local_cols()

amgprec/impl/aggregator/amg_zaggrmat_smth_bld.f90

@@ -69,6 +69,8 @@
 !
 !
 ! Arguments:
+!    dol1smooth -  Integer taking the type of smoother that has to be used
+!                  on the tentative prolongator
 !    a          -  type(psb_zspmat_type), input.     
 !                  The sparse matrix structure containing the local part of
 !                  the fine-level matrix.
@@ -102,8 +104,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
-     & ac,desc_ac,op_prol,op_restr,t_prol,info)
+subroutine amg_zaggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
+                parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use amg_base_prec_type
   use amg_z_inner_mod, amg_protect_name => amg_zaggrmat_smth_bld
@@ -112,6 +114,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   implicit none
 
   ! Arguments
+  integer(psb_ipk_), intent(in)            :: dol1smoothing
   type(psb_zspmat_type), intent(in)      :: a
   type(psb_desc_type), intent(inout)       :: desc_a
   integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
@@ -132,7 +135,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   type(psb_z_coo_sparse_mat) :: coo_prol, coo_restr
   type(psb_z_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
   complex(psb_dpk_), allocatable :: adiag(:)
-  real(psb_dpk_), allocatable :: arwsum(:)
+  real(psb_dpk_), allocatable :: arwsum(:),l1rwsum(:)
   integer(psb_ipk_)  :: ierr(5)
   logical            :: filter_mat
   integer(psb_ipk_)            :: debug_level, debug_unit, err_act
@@ -141,6 +144,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   logical, parameter :: debug_new=.false.
   character(len=80) :: filename
   logical, parameter :: do_timings=.false.
+  logical :: do_l1correction=.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
 
@@ -173,6 +177,9 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if ((do_timings).and.(idx_ptap==-1)) &
        & idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld  ")
 
+  ! check if we have to use Jacobi or l1-Jacobi to smooth the tentative prolongator
+  if (dol1smoothing.eq.amg_l1_smooth_prol_) do_l1correction=.true.
+
 
   nglob = desc_a%get_global_rows()
   nrow  = desc_a%get_local_rows()
@@ -200,6 +207,24 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
+  !
+  ! Do the l1-correction on the diagonal if it is requested
+  !
+  if (do_l1correction) then
+    allocate(l1rwsum(nrow))
+    call acsr%arwsum(l1rwsum)
+    if (info == psb_success_) &
+      & call psb_realloc(ncol,l1rwsum,info)
+    if (info == psb_success_) &
+      & call psb_halo(l1rwsum,desc_a,info)
+    ! \tilde{D}_{i,i} = \sum_{j \ne i} |a_{i,j}|
+    !$OMP parallel do private(i) schedule(static)
+    do i=1,size(adiag)
+      adiag(i) = adiag(i) + l1rwsum(i) - abs(adiag(i))
+    end do
+    !$OMP end parallel do
+  end if
+
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -230,6 +255,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
 
       enddo
       if (jd == -1) then 
+        ! if (.not.do_l1correction) 
         write(0,*) 'Wrong input: we need the diagonal!!!!', i
       else
         acsrf%val(jd)=acsrf%val(jd)-tmp
@@ -252,6 +278,10 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   !$OMP end parallel do 
   if (parms%aggr_omega_alg == amg_eig_est_) then 
 
+    !if (do_l1correction) then
+    !  ! For l1-Jacobi this can be estimated with 1
+    !  parms%aggr_omega_val = done
+    !
     if (parms%aggr_eig == amg_max_norm_) then 
       allocate(arwsum(nrow))
       call acsr%arwsum(arwsum)      
@@ -259,7 +289,6 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
       call psb_amx(ctxt,anorm)
       omega = 4.d0/(3.d0*anorm)
       parms%aggr_omega_val = omega 
-
     else 
       info = psb_err_internal_error_
       call psb_errpush(info,name,a_err='invalid amg_aggr_eig_')
@@ -322,6 +351,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),&
        & 'Done smooth_aggregate '
+  if (allocated(l1rwsum)) deallocate(l1rwsum)
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/clean.cpp

@@ -1,6 +1,6 @@
 #include "MatchBoxPC.h"
-
 // TODO comment
+#if !defined(SERIAL_MPI)
 
 void clean(MilanLongInt NLVer,
            MilanInt myRank,
@@ -89,3 +89,4 @@ void clean(MilanLongInt NLVer,
         }
     }
 }
+#endif

amgprec/impl/aggregator/computeCandidateMate.cpp

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

amgprec/impl/aggregator/extractUChunk.cpp

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

amgprec/impl/aggregator/findOwnerOfGhost.cpp

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

amgprec/impl/aggregator/initialize.cpp

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

amgprec/impl/aggregator/isAlreadyMatched.cpp

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

amgprec/impl/aggregator/parallelComputeCandidateMateB.cpp

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

amgprec/impl/aggregator/processCrossEdge.cpp

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

amgprec/impl/aggregator/processExposedVertex.cpp

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

amgprec/impl/aggregator/processMatchedVertices.cpp

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

amgprec/impl/aggregator/processMatchedVerticesAndSendMessages.cpp

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

amgprec/impl/aggregator/processMessages.cpp

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

amgprec/impl/aggregator/queueTransfer.cpp

@@ -1,5 +1,4 @@
 #include "MatchBoxPC.h"
-
 void queuesTransfer(vector<MilanLongInt> &U,
                     vector<MilanLongInt> &privateU,
                     vector<MilanLongInt> &QLocalVtx,
@@ -15,22 +14,20 @@ void queuesTransfer(vector<MilanLongInt> &U,
 #pragma omp critical(U)
     {
         U.insert(U.end(), privateU.begin(), privateU.end());
-    }
-
-    privateU.clear();
-
-#pragma omp critical(sendMessageTransfer)
-    {
 
+    //#pragma omp critical(sendMessageTransfer)
+    //{
         QLocalVtx.insert(QLocalVtx.end(), privateQLocalVtx.begin(), privateQLocalVtx.end());
         QGhostVtx.insert(QGhostVtx.end(), privateQGhostVtx.begin(), privateQGhostVtx.end());
         QMsgType.insert(QMsgType.end(), privateQMsgType.begin(), privateQMsgType.end());
         QOwner.insert(QOwner.end(), privateQOwner.begin(), privateQOwner.end());
     }
 
+    privateU.clear();
     privateQLocalVtx.clear();
     privateQGhostVtx.clear();
     privateQMsgType.clear();
     privateQOwner.clear();
 
 }
+

amgprec/impl/aggregator/sendBundledMessages.cpp

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

amgprec/impl/amg_c_hierarchy_bld.F90

@@ -451,11 +451,16 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
     if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
       prec%precv(1)%base_desc => prec%precv(1)%desc_ac
     end if
-    do i=2, iszv 
+    do i=2, iszv
       prec%precv(i)%base_a       => prec%precv(i)%ac
       prec%precv(i)%base_desc    => prec%precv(i)%desc_ac
-      prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
-      prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
+      ! This is needed when the linmap object has been built
+      ! reusing the base_desc descriptor through a pointer.
+      ! With PSBLAS 4 we will have a better solution
+      if (associated(prec%precv(i)%linmap%p_desc_U)) &
+           & prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
+      if (associated(prec%precv(i)%linmap%p_desc_V))&
+           & prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
     end do
   end if
 
@@ -507,6 +512,71 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
   return
 
 contains
+
+#if ( __GNUC__ == 13 && __GNUC_MINOR__ == 3) 
+  ! gfortran 13.3.0 generates a strange error here with MOLD
+  ! moving to SOURCE but only for this version, since it's heavier
+  subroutine save_smoothers(level,save1, save2,info)
+    type(amg_c_onelev_type), intent(inout) :: level
+    class(amg_c_base_smoother_type), allocatable , intent(inout) :: save1, save2
+    integer(psb_ipk_), intent(out) :: info
+
+    info  = 0 
+    if (allocated(save1)) then
+      call save1%free(info)
+      if (info  == 0) deallocate(save1,stat=info)
+      if (info /= 0) return
+    end if
+    if (allocated(save2)) then
+      call save2%free(info)
+      if (info  == 0) deallocate(save2,stat=info)
+      if (info /= 0) return
+    end if
+    allocate(save1, source=level%sm,stat=info)
+    if (info == 0) call level%sm%clone_settings(save1,info)
+    if ((info == 0).and.allocated(level%sm2a)) then
+      allocate(save2, source=level%sm2a,stat=info) 
+      if (info == 0) call level%sm2a%clone_settings(save2,info)
+    end if
+
+    return
+  end subroutine save_smoothers
+
+  subroutine restore_smoothers(level,save1, save2,info)
+    type(amg_c_onelev_type), intent(inout), target :: level
+    class(amg_c_base_smoother_type), allocatable, intent(inout) :: save1, save2
+    integer(psb_ipk_), intent(out) :: info
+
+    info  = 0
+
+    if (allocated(level%sm)) then
+      if (info  == 0) call level%sm%free(info)
+      if (info  == 0) deallocate(level%sm,stat=info)
+    end if
+    if (allocated(save1)) then
+      if (info  == 0) allocate(level%sm,source=save1,stat=info)
+      if (info == 0) call save1%clone_settings(level%sm,info)
+    end if
+
+    if (info /= 0) return
+
+    if (allocated(level%sm2a)) then
+      if (info  == 0) call level%sm2a%free(info)
+      if (info  == 0) deallocate(level%sm2a,stat=info)
+    end if
+    if (allocated(save2)) then
+      if (info  == 0) allocate(level%sm2a,source=save2,stat=info)
+      if (info == 0) call save2%clone_settings(level%sm2a,info)
+      if (info  == 0) level%sm2 => level%sm2a
+    else
+      if (allocated(level%sm)) level%sm2 => level%sm
+    end if
+
+    return
+  end subroutine restore_smoothers
+
+#else
+
   subroutine save_smoothers(level,save1, save2,info)
     type(amg_c_onelev_type), intent(inout) :: level
     class(amg_c_base_smoother_type), allocatable , intent(inout) :: save1, save2
@@ -565,5 +635,5 @@ contains
 
     return
   end subroutine restore_smoothers
-
+#endif
 end subroutine amg_c_hierarchy_bld

amgprec/impl/amg_c_smoothers_bld.f90

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

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
@@ -193,6 +194,15 @@ subroutine amg_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
         end if
         call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
 
+      case('COARSE_INVFILL')
+        if (ilev_ /= nlev_) then
+          write(psb_err_unit,*) name,&
+               & ': Error: Inconsistent specification of WHAT vs. ILEV'
+          info = -2
+          return
+        end if
+        call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
+
      case('BJAC_ITRACE')
        if (ilev_ /= nlev_) then
          write(psb_err_unit,*) name,&
@@ -242,6 +252,11 @@ subroutine amg_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
         call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
       end if
 
+    case('COARSE_INVFILL')
+      if (nlev_ > 1) then
+        call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
+      end if
+
     case('BJAC_ITRACE')
       if (nlev_ > 1) then
         call p%precv(nlev_)%set('SMOOTHER_ITRACE',val,info,pos=pos)
@@ -308,6 +323,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
@@ -336,7 +352,8 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
   ! Local variables
   integer(psb_ipk_)                      :: ilev_, nlev_,val,ilmax_, il
   character(len=*), parameter            :: name='amg_precsetc'
-
+  logical :: hier_asb
+  
   info = psb_success_
 
   if (.not.allocated(p%precv)) then
@@ -459,6 +476,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
           return
         end if
         if (nlev_ > 1) then
+          hier_asb = p%precv(nlev_)%ac%is_asb()          
           select case (psb_toupper(string))
           case('BJAC')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
@@ -467,9 +485,13 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
 #elif defined(HAVE_MUMPS_)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
 #else
-            call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
 #endif
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info)
+
           case('L1-BJAC')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_l1_bjac_,info,pos=pos)
 #if defined(HAVE_SLU_)
@@ -477,57 +499,93 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
 #elif defined(HAVE_MUMPS_)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
 #else
-            call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
 #endif
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info)
           case('SLU')
 #if defined(HAVE_SLU_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_slu_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_repl_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #else
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-            call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #endif
           case('ILU')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-            call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_repl_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
           case('ILUT')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-            call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_repl_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
           case('MILU')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-            call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_repl_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
           case('MUMPS')
 #if defined(HAVE_MUMPS_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #else
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-            call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #endif
          case('UMF')
 #if defined(HAVE_SLU_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_slu_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_repl_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #else
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-            call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #endif
 
@@ -535,42 +593,69 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
 #if defined(HAVE_SLU_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_slu_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_repl_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_repl_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #else
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-            call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #endif
           case('JACOBI','JAC')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_diag_scale_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 
           case('L1-JACOBI','L1-JAC')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_l1_diag_scale_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
           case('GS','FBGS')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_gs_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
           case('BWGS')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_bwgs_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
           case('L1-GS','L1-FBGS')
             call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_l1_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',amg_gs_,info,pos=pos)
+            if (hier_asb) &
+                 & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                 & amg_distr_mat_)
             call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
           case('KRM')
             block
               type(amg_c_krm_solver_type)          :: krm_slv
               call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
               call p%precv(nlev_)%set(krm_slv,info)
+              if (hier_asb) &
+                   & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                   & amg_distr_mat_)
               call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
             end block
           end select
@@ -610,11 +695,16 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
 
     case('COARSE_MAT')
       if (nlev_ > 1) then
+        hier_asb = p%precv(nlev_)%ac%is_asb()                  
+        if (hier_asb) &
+             & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+             & amg_stringval(string))
         call p%precv(nlev_)%set('COARSE_MAT',string,info,pos=pos)
       end if
 
     case('COARSE_SOLVE')
       if (nlev_ > 1) then
+        hier_asb = p%precv(nlev_)%ac%is_asb()          
         call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
         select case (psb_toupper(trim(string)))
         case('BJAC')
@@ -624,8 +714,11 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
 #elif defined(HAVE_MUMPS_)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
 #endif
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info)
         case('L1-BJAC')
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_l1_bjac_,info,pos=pos)
@@ -634,57 +727,93 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
 #elif defined(HAVE_MUMPS_)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
 #endif
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info)
         case('SLU')
 #if defined(HAVE_SLU_)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_slu_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_repl_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #else
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #endif
         case('ILU')
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_repl_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
         case('ILUT')
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_repl_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
         case('MILU')
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_repl_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
         case('MUMPS')
 #if defined(HAVE_MUMPS_)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #else
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #endif
         case('UMF')
 #if defined(HAVE_SLU_)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_slu_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_repl_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #else
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #endif
 
@@ -692,42 +821,69 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
 #if defined(HAVE_SLU_)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_slu_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_repl_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #else
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 #endif
         case('JACOBI','JAC')
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_diag_scale_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
 
         case('L1-JACOBI','L1-JAC')
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_l1_diag_scale_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
         case('GS','FBGS')
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_gs_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
         case('BWGS')
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_bwgs_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
         case('L1-FBGS','L1-GS')
           call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_l1_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',amg_gs_,info,pos=pos)
+          if (hier_asb) &
+               & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+               & amg_distr_mat_)
           call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
           case('KRM')
             block
               type(amg_c_krm_solver_type)          :: krm_slv
               call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos)
               call p%precv(nlev_)%set(krm_slv,info)
+              if (hier_asb) &
+                   & call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
+                   & amg_distr_mat_)
               call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
             end block
         end select

amgprec/impl/amg_cfile_prec_descr.f90

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

amgprec/impl/amg_cfile_prec_memory_use.f90

@@ -0,0 +1,152 @@
+!   
+!   
+!                             AMG4PSBLAS version 1.0
+!    Algebraic Multigrid Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.7)
+!    
+!    (C) Copyright 2021 
+!  
+!        Salvatore Filippone  
+!        Pasqua D'Ambra   
+!        Fabio Durastante        
+!   
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the AMG4PSBLAS group or the names of its contributors may
+!         not be used to endorse or promote products derived from this
+!         software without specific written permission.
+!   
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
+!    BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!    CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!    ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!    POSSIBILITY OF SUCH DAMAGE.
+!   
+!  
+! File: amg_dfile_prec_memory_use.f90
+!
+!
+! Subroutine: amg_file_prec_memory_use
+! Version: complex
+!
+!  This routine prints a memory_useiption of the preconditioner to the standard 
+!  output or to a file. It must be called after the preconditioner has been
+!  built by amg_precbld.
+!
+! Arguments:
+!  p       -  type(amg_Tprec_type), input.
+!             The preconditioner data structure to be printed out.
+!  info    -  integer, output.
+!             error code.
+!  iout    -  integer, input, optional.
+!             The id of the file where the preconditioner description
+!             will be printed. If iout is not present, then the standard
+!             output is condidered.
+!  root    -  integer, input, optional.
+!             The id of the process printing the message; -1 acts as a wildcard.
+!             Default is psb_root_
+!
+!
+!
+! verbosity:
+!        <0: suppress all messages
+!         0: normal
+!        >1: increased details 
+!
+subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,global)
+  use psb_base_mod
+  use amg_c_prec_mod, amg_protect_name => amg_cfile_prec_memory_use
+  use amg_c_inner_mod
+  use amg_c_gs_solver
+
+  implicit none 
+  ! Arguments
+  class(amg_cprec_type), intent(in)     :: prec
+  integer(psb_ipk_), intent(out)          :: info
+  integer(psb_ipk_), intent(in), optional :: iout
+  integer(psb_ipk_), intent(in), optional :: root
+  integer(psb_ipk_), intent(in), optional :: verbosity
+  character(len=*), intent(in), optional  :: prefix
+  logical, intent(in), optional           :: global
+
+
+  ! Local variables
+  integer(psb_ipk_)   :: ilev, nlev, ilmin, nswps
+  type(psb_ctxt_type) :: ctxt
+  integer(psb_ipk_)   :: me, np
+  logical             :: is_symgs
+  character(len=20), parameter :: name='amg_file_prec_memory_use'
+  integer(psb_ipk_)  :: iout_, root_, verbosity_
+  logical            :: global_
+  character(1024)    :: prefix_
+
+  info = psb_success_
+  if (present(iout)) then 
+    iout_ = iout
+  else
+    iout_ = psb_out_unit
+  end if
+  if (iout_ < 0) iout_ = psb_out_unit
+  if (present(verbosity)) then
+    verbosity_ = verbosity
+  else
+    verbosity_ = 0
+  end if
+  if (verbosity_ < 0) goto 9998
+
+  ctxt = prec%ctxt
+  call psb_info(ctxt,me,np)
+  prefix_ = ""
+  if (verbosity_ == 0) then 
+    if (present(prefix)) then
+      prefix_ = prefix
+    end if
+  else if (verbosity_ > 0) then 
+    if (present(prefix)) then
+      write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': '
+    else
+      write(prefix_,'(a,i5,a)') 'Process ',me,': '
+    end if
+
+  end if
+  
+  if (present(root)) then 
+    root_ = root
+  else
+    root_ = psb_root_
+  end if
+  if (root_ == -1) root_ = me
+
+  if (allocated(prec%precv)) then
+    if (verbosity_ >=0) then 
+      if (me == root_) then
+        write(iout_,*) 
+        write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage'
+      end if
+      nlev = size(prec%precv)
+      do ilev=1,nlev
+        call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, &
+             & iout=iout_,verbosity=verbosity_,prefix=trim(prefix_),global=global)
+      end do
+
+    else
+      write(iout_,*) trim(name), &
+           & ': Error: no base preconditioner available, something is wrong!'
+      info = -2
+      return
+    endif
+  end if
+9998 continue
+end subroutine amg_cfile_prec_memory_use