Merge branch 'development' into ExperimentMixed

amgprec/CMakeLists.txt

@@ -509,7 +509,6 @@ set(AMG_amgprec_source_files
   impl/smoother/amg_s_base_smoother_free.f90
   impl/smoother/amg_d_jac_smoother_clone.f90
   impl/smoother/amg_d_jac_smoother_apply_vect.f90
-  impl/smoother/amg_d_richards_smoother_impl.f90
   impl/smoother/amg_c_as_smoother_clear_data.f90
   impl/smoother/amg_s_poly_smoother_descr.f90
   impl/smoother/amg_z_as_smoother_cseti.f90
@@ -774,7 +773,6 @@ set(AMG_amgprec_source_files
   amg_prec_mod.f90
   amg_d_gs_solver.f90
   amg_d_jac_smoother.f90
-  amg_d_richards_smoother.f90
   amg_z_symdec_aggregator_mod.f90
   amg_s_gs_solver.f90
   amg_ainv_mod.f90

amgprec/Makefile

@@ -8,7 +8,7 @@ FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES)
 
 
 DMODOBJS=amg_d_prec_type.o \
-	amg_d_inner_mod.o amg_d_ilu_solver.o amg_d_diag_solver.o amg_d_jac_smoother.o amg_d_as_smoother.o amg_d_richards_smoother.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 \
@@ -159,7 +159,7 @@ amg_d_umf_solver.o amg_d_diag_solver.o amg_d_ilu_solver.o amg_d_jac_solver.o: am
 
 #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
-amg_d_as_smoother.o amg_d_jac_smoother.o amg_d_richards_smoother.o: amg_d_base_smoother_mod.o
+amg_d_as_smoother.o amg_d_jac_smoother.o: amg_d_base_smoother_mod.o
 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 \

amgprec/amg_base_prec_type.F90

@@ -216,8 +216,7 @@ module amg_base_prec_type
   integer(psb_ipk_), parameter :: amg_l1_gs_    = 7
   integer(psb_ipk_), parameter :: amg_l1_fbgs_  = 8
   integer(psb_ipk_), parameter :: amg_poly_     = 9
-  integer(psb_ipk_), parameter :: amg_richardson_ = 10
-  integer(psb_ipk_), parameter :: amg_max_prec_ = 10
+  integer(psb_ipk_), parameter :: amg_max_prec_ = 9
   !
   ! Constants for pre/post signaling. Now only used internally
   !
@@ -230,8 +229,7 @@ module amg_base_prec_type
   !
   ! Legal values for entry: amg_sub_solve_
   !
-  ! Keep this fixed so sub-solver numeric IDs remain stable.
-  integer(psb_ipk_), parameter :: amg_slv_delta_     = 10
+  integer(psb_ipk_), parameter :: amg_slv_delta_     = amg_max_prec_+1
   integer(psb_ipk_), parameter :: amg_f_none_        = amg_slv_delta_+0
   integer(psb_ipk_), parameter :: amg_diag_scale_    = amg_slv_delta_+1
   integer(psb_ipk_), parameter :: amg_l1_diag_scale_ = amg_slv_delta_+2
@@ -411,7 +409,7 @@ module amg_base_prec_type
        & 'none          ','Jacobi        ',&
        & 'L1-Jacobi     ','none          ','none          ',&
        & 'none          ','none          ','L1-GS         ',&
-      & 'L1-FBGS       ','Polynomial    ', 'Richards      ','Point Jacobi  ',&
+       & 'L1-FBGS       ','Polynomial    ','none          ','Point Jacobi  ',&
        & 'L1-Jacobi     ','Gauss-Seidel  ','ILU(n)        ',&
        & 'MILU(n)       ','ILU(t,n)      ',&
        & 'SuperLU       ','UMFPACK LU    ',&
@@ -577,8 +575,6 @@ contains
       val = amg_as_
     case('POLY')
       val = amg_poly_
-    case('RICHARDSON','RICHARDS')
-      val = amg_richardson_
     case('CHEB_4')
       val = amg_cheb_4_
     case('CHEB_4_OPT')
@@ -1206,8 +1202,6 @@ contains
       pr_to_str='BJAC'
     case(amg_as_)
       pr_to_str='AS'
-    case(amg_richardson_)
-      pr_to_str='RICHARDS'
     end select
 
   end function pr_to_str

amgprec/amg_c_base_aggregator_mod.f90

@@ -89,7 +89,7 @@ module amg_c_base_aggregator_mod
     procedure, pass(ag) :: bld_tprol   => amg_c_base_aggregator_build_tprol
     procedure, pass(ag) :: mat_bld     => amg_c_base_aggregator_mat_bld
     procedure, pass(ag) :: mat_asb     => amg_c_base_aggregator_mat_asb
-    procedure, pass(ag) :: bld_map     => amg_c_base_aggregator_bld_map
+    procedure, pass(ag) :: bld_linmap  => amg_c_base_aggregator_bld_linmap
     procedure, pass(ag) :: update_next => amg_c_base_aggregator_update_next
     procedure, pass(ag) :: clone       => amg_c_base_aggregator_clone
     procedure, pass(ag) :: free        => amg_c_base_aggregator_free
@@ -458,7 +458,7 @@ contains
   end subroutine amg_c_base_aggregator_mat_asb
 
   !
-  !> Function   bld_map
+  !> Function   bld_linmap
   !! \memberof  amg_c_base_aggregator_type
   !! \brief     Build linear map between hierarchy levels 
   !!
@@ -473,7 +473,7 @@ contains
   !!  \param map       The output map
   !!  \param info    Return code
   !!  
-  subroutine  amg_c_base_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_c_base_aggregator_bld_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
        & op_restr,op_prol,map,info)
     use psb_base_mod
     implicit none
@@ -484,7 +484,7 @@ contains
     type(psb_clinmap_type), intent(out)    :: map
     integer(psb_ipk_), intent(out)       :: info
     integer(psb_ipk_) :: err_act
-    character(len=20) :: name='c_base_aggregator_bld_map'
+    character(len=20) :: name='c_base_aggregator_bld_linmap'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -508,7 +508,6 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_c_base_aggregator_bld_map
-
+  end subroutine amg_c_base_aggregator_bld_linmap
 
 end module amg_c_base_aggregator_mod

amgprec/amg_c_inner_mod.f90

@@ -67,7 +67,7 @@ module amg_c_inner_mod
   end interface amg_mlprec_bld
 
   interface amg_mlprec_aply
-    subroutine amg_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
+    subroutine amg_cmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info)
       import :: psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_
       import :: amg_cprec_type
       implicit none 
@@ -79,7 +79,7 @@ module amg_c_inner_mod
       character,intent(in)               :: trans
       complex(psb_spk_),target             :: work(:)
       integer(psb_ipk_), intent(out)     :: info
-    end subroutine amg_cmlprec_aply
+    end subroutine amg_cmlprec_aply_a
     subroutine amg_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
       import :: psb_cspmat_type, psb_desc_type, &
            & psb_spk_, psb_c_vect_type, psb_ipk_

amgprec/amg_c_onelev_mod.f90

@@ -154,13 +154,35 @@ module amg_c_onelev_mod
   private :: c_wrk_alloc, c_wrk_free, &
        & c_wrk_clone, c_wrk_move_alloc, c_wrk_cnv, c_wrk_sizeof
 
+  !
+  ! Remap.
+  !  This keeps track of remapping.
+  !  Logic here is as follows:
+  !  1. AC_PRE_REMAP  need to figure out if we
+  !                really need it.
+  !  2. DESC_AC_PRE_REMAP  contains the descriptor before
+  !                remapping. Meaning that it is possible
+  !                to implement the RESTRICTOR operator by
+  !                 a. Doing LINMAP_U2V onto this one
+  !                 b. For each process, send the data to
+  !                    IDEST.
+  !                This assumes that remapping goes by
+  !                a factor of 2.
+  !                For the PROLONGATOR operators, we first
+  !                use DESC_AC, then split and send onto
+  !                the processes in DESC_AC_PRE_REMAP.
+  !
+  ! To be fixed: what happens if NP the starting processes
+  ! is not an even number? Coordinate with _X_remap in PSBLAS
+  ! 
   type amg_c_remap_data_type
     type(psb_cspmat_type)          :: ac_pre_remap
     type(psb_desc_type)            :: desc_ac_pre_remap
     integer(psb_ipk_)              :: idest
     integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
   contains
-    procedure, pass(rmp) :: clone   => c_remap_data_clone
+    procedure, pass(rmp) :: clone      => c_remap_data_clone
+    procedure, pass(rmp) :: move_alloc => c_remap_move_alloc
   end type amg_c_remap_data_type
 
   type amg_c_onelev_type
@@ -206,7 +228,7 @@ module amg_c_onelev_mod
     procedure, pass(lv) :: get_wrksz => c_base_onelev_get_wrksize
     procedure, pass(lv) :: allocate_wrk   => c_base_onelev_allocate_wrk
     procedure, pass(lv) :: free_wrk       => c_base_onelev_free_wrk
-    procedure, nopass   :: stringval => amg_stringval
+    procedure, nopass   :: stringval  => amg_stringval
     procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc
 
 
@@ -230,9 +252,7 @@ module amg_c_onelev_mod
        & c_base_onelev_free_wrk
 
   interface
-    subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
-      import :: psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lcspmat_type, psb_lpk_
-      import :: amg_c_onelev_type
+    module subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
       implicit none
       class(amg_c_onelev_type), intent(inout), target :: lv
       type(psb_cspmat_type), intent(in) :: a
@@ -244,10 +264,7 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
-      import :: psb_c_base_sparse_mat, psb_c_base_vect_type, &
-           & psb_i_base_vect_type, psb_spk_, amg_c_onelev_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       integer(psb_ipk_), intent(out) :: info
@@ -259,10 +276,7 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
-      import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
-           & psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
       Implicit None
       ! Arguments
       class(amg_c_onelev_type), intent(in)    :: lv
@@ -275,10 +289,8 @@ module amg_c_onelev_mod
   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
+    module subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,&
+         & iout,verbosity, prefix,global) 
       Implicit None
       ! Arguments
       class(amg_c_onelev_type), intent(in)    :: lv
@@ -292,10 +304,7 @@ module amg_c_onelev_mod
   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_, &
-           & psb_c_base_sparse_mat, psb_ipk_, psb_i_base_vect_type
-      ! Arguments
+    module subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
       class(amg_c_onelev_type), intent(inout)            :: lv
       integer(psb_ipk_), intent(out)                     :: info
       class(psb_c_base_sparse_mat), intent(in), optional :: amold
@@ -305,48 +314,32 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_free(lv,info)
-      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
+    module subroutine amg_c_base_onelev_free(lv,info)
       implicit none
-
       class(amg_c_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)                :: info
     end subroutine amg_c_base_onelev_free
   end interface
 
   interface
-    subroutine amg_c_base_onelev_free_smoothers(lv,info)
-      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
+    module subroutine amg_c_base_onelev_free_smoothers(lv,info)
       implicit none
-
       class(amg_c_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)                :: info
     end subroutine amg_c_base_onelev_free_smoothers
   end interface
 
   interface
-    subroutine amg_c_base_onelev_check(lv,info)
-      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
+    module subroutine amg_c_base_onelev_check(lv,info)
       Implicit None
-      ! Arguments
       class(amg_c_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)            :: info
     end subroutine amg_c_base_onelev_check
   end interface
 
   interface
-    subroutine amg_c_base_onelev_setsm(lv,val,info,pos)
-      import :: psb_spk_, amg_c_onelev_type, amg_c_base_smoother_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_c_base_onelev_setsm(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_c_onelev_type), target, intent(inout) :: lv
       class(amg_c_base_smoother_type), intent(in)     :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -355,12 +348,8 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_setsv(lv,val,info,pos)
-      import :: psb_spk_, amg_c_onelev_type, amg_c_base_solver_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_c_base_onelev_setsv(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_c_onelev_type), target, intent(inout) :: lv
       class(amg_c_base_solver_type), intent(in)       :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -369,12 +358,8 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_setag(lv,val,info,pos)
-      import :: psb_spk_, amg_c_onelev_type, amg_c_base_aggregator_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_c_base_onelev_setag(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_c_onelev_type), target, intent(inout) :: lv
       class(amg_c_base_aggregator_type), intent(in)       :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -383,13 +368,8 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
       Implicit None
-
-      ! Arguments
       class(amg_c_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       integer(psb_ipk_), intent(in)             :: val
@@ -400,12 +380,8 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
       Implicit None
-      ! Arguments
       class(amg_c_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       character(len=*), intent(in)              :: val
@@ -416,12 +392,8 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
       Implicit None
-
       class(amg_c_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       real(psb_spk_), intent(in)                 :: val
@@ -432,11 +404,8 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
+    module subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
          & solver,tprol,global_num)
-      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
       class(amg_c_onelev_type), intent(in) :: lv
       integer(psb_ipk_), intent(in)          :: level
@@ -447,8 +416,7 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
-      import
+    module subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       complex(psb_spk_), intent(in)     :: alpha, beta
@@ -457,8 +425,8 @@ module amg_c_onelev_mod
       integer(psb_ipk_), intent(out) :: info
       complex(psb_spk_), optional       :: work(:)
     end subroutine amg_c_base_onelev_map_rstr_a
-    subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
-      import
+    module subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
+         & work,vtx,vty)
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       complex(psb_spk_), intent(in)           :: alpha, beta
@@ -470,8 +438,7 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
-      import
+    module subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       complex(psb_spk_), intent(in)     :: alpha, beta
@@ -481,8 +448,8 @@ module amg_c_onelev_mod
       complex(psb_spk_), optional          :: work(:)
 
     end subroutine amg_c_base_onelev_map_prol_a
-    subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
-      import
+    module subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
+         & work,vtx,vty)
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       complex(psb_spk_), intent(in)           :: alpha, beta
@@ -493,6 +460,118 @@ module amg_c_onelev_mod
     end subroutine amg_c_base_onelev_map_prol_v
   end interface
 
+  interface 
+    module subroutine c_base_onelev_move_alloc(lv, b,info)
+      implicit none
+      class(amg_c_onelev_type), target, intent(inout) :: lv, b
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine c_base_onelev_move_alloc
+  end interface
+
+  interface 
+    module subroutine c_base_onelev_allocate_wrk(lv,info,vmold)
+      implicit none
+      class(amg_c_onelev_type), target, intent(inout) :: lv
+      integer(psb_ipk_), intent(out) :: info
+      class(psb_c_base_vect_type), intent(in), optional  :: vmold
+    end subroutine c_base_onelev_allocate_wrk
+  end interface
+  
+  interface 
+    module subroutine c_base_onelev_free_wrk(lv,info)
+      implicit none
+      class(amg_c_onelev_type), target, intent(inout) :: lv
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine c_base_onelev_free_wrk
+  end interface
+
+  interface 
+    module  subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
+      Implicit None
+      ! Arguments
+      class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(in)                     :: nwv
+      type(psb_desc_type), intent(in)                   :: desc
+      integer(psb_ipk_), intent(out)                    :: info
+      class(psb_c_base_vect_type), intent(in), optional  :: vmold
+      type(psb_desc_type), intent(in), optional          :: desc2
+    end subroutine c_wrk_alloc
+  end interface
+
+  interface 
+    module subroutine c_inner_do_wrk_alloc(wk,nwv,desc,vmold)
+      class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(in)                     :: nwv
+      type(psb_desc_type), intent(in)                   :: desc
+      class(psb_c_base_vect_type), intent(in), optional  :: vmold
+    end subroutine c_inner_do_wrk_alloc
+  end interface
+
+  interface 
+    module  subroutine c_wrk_free(wk,info)
+      Implicit None
+      ! Arguments
+      class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine c_wrk_free
+  end interface
+
+  interface 
+    module  subroutine c_wrk_clone(wk,wkout,info)
+      Implicit None
+      ! Arguments
+      class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+      class(amg_cmlprec_wrk_type), target, intent(inout) :: wkout
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine c_wrk_clone
+  end interface
+
+  interface 
+    module subroutine c_wrk_move_alloc(wk, b,info)
+      implicit none
+      class(amg_cmlprec_wrk_type), target, intent(inout) :: wk, b
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine c_wrk_move_alloc
+  end interface
+
+  interface
+    module subroutine c_wrk_cnv(wk,info,vmold)
+      Implicit None
+      class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(out)                    :: info
+      class(psb_c_base_vect_type), intent(in), optional  :: vmold
+    end subroutine c_wrk_cnv
+  end interface
+
+  interface
+    module function c_wrk_sizeof(wk) result(val)
+      implicit none
+      class(amg_cmlprec_wrk_type), intent(in) :: wk
+      integer(psb_epk_) :: val
+    end  function c_wrk_sizeof
+  end interface
+
+  interface 
+    module subroutine c_remap_data_clone(rmp, remap_out, info)
+      implicit none
+      ! Arguments
+      class(amg_c_remap_data_type), target, intent(inout) :: rmp
+      class(amg_c_remap_data_type), target, intent(inout) :: remap_out
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine c_remap_data_clone
+  end interface
+
+  interface 
+    module subroutine c_remap_move_alloc(rmp, remap_out, info)
+      implicit none
+      ! Arguments
+      class(amg_c_remap_data_type), target, intent(inout) :: rmp
+      class(amg_c_remap_data_type), target, intent(inout) :: remap_out
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine c_remap_move_alloc
+  end interface
+  
+
 contains
   !
   ! Function returning the size of the amg_prec_type data structure
@@ -618,7 +697,7 @@ contains
     ! Arguments
     class(amg_c_onelev_type), target, intent(inout) :: lv
     class(amg_c_onelev_type), target, intent(inout) :: lvout
-    integer(psb_ipk_), intent(out)                    :: info
+    integer(psb_ipk_), intent(out)                  :: info
 
     info = psb_success_
     if (allocated(lv%sm)) then
@@ -660,36 +739,6 @@ contains
 
   end subroutine c_base_onelev_clone
 
-  subroutine c_base_onelev_move_alloc(lv, b,info)
-    use psb_base_mod
-    implicit none
-    class(amg_c_onelev_type), target, intent(inout) :: lv, b
-    integer(psb_ipk_), intent(out) :: info
-
-    call b%free(info)
-    b%parms  = lv%parms
-    b%szratio = lv%szratio
-    if (associated(lv%sm2,lv%sm2a)) then
-      call move_alloc(lv%sm,b%sm)
-      call move_alloc(lv%sm2a,b%sm2a)
-      b%sm2 =>b%sm2a
-    else
-      call move_alloc(lv%sm,b%sm)
-      call move_alloc(lv%sm2a,b%sm2a)
-      b%sm2 =>b%sm
-    end if
-
-    call move_alloc(lv%aggr,b%aggr)
-    if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
-    if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
-    if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
-    if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
-    b%base_a    => lv%base_a
-    b%base_desc => lv%base_desc
-
-  end subroutine c_base_onelev_move_alloc
-
-
   function c_base_onelev_get_wrksize(lv) result(val)
     implicit none
     class(amg_c_onelev_type), intent(inout) :: lv
@@ -727,269 +776,5 @@ contains
 
   end function c_base_onelev_get_wrksize
 
-  subroutine c_base_onelev_allocate_wrk(lv,info,vmold)
-    use psb_base_mod
-    implicit none
-    class(amg_c_onelev_type), target, intent(inout) :: lv
-    integer(psb_ipk_), intent(out) :: info
-    class(psb_c_base_vect_type), intent(in), optional  :: vmold
-    !
-    integer(psb_ipk_) :: nwv, i
-    info = psb_success_
-    nwv = lv%get_wrksz()
-    if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
-    if (info == 0) then
-      if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
-        !
-        !  Need to fix this, we need two different allocations
-        !
-        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
-             & desc2=lv%remap_data%desc_ac_pre_remap)
-      else
-        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
-      end if
-    end if
-
-  end subroutine c_base_onelev_allocate_wrk
-
-
-  subroutine c_base_onelev_free_wrk(lv,info)
-    use psb_base_mod
-    implicit none
-    class(amg_c_onelev_type), target, intent(inout) :: lv
-    integer(psb_ipk_), intent(out) :: info
-    !
-    integer(psb_ipk_) :: nwv,i
-    info = psb_success_
-
-    if (allocated(lv%wrk)) then
-      call lv%wrk%free(info)
-      if (info == 0) deallocate(lv%wrk,stat=info)
-    end if
-  end subroutine c_base_onelev_free_wrk
-
-  subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(in)                     :: nwv
-    type(psb_desc_type), intent(in)                   :: desc
-    integer(psb_ipk_), intent(out)                    :: info
-    class(psb_c_base_vect_type), intent(in), optional  :: vmold
-    type(psb_desc_type), intent(in), optional          :: desc2
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-    call wk%free(info)
-    if  (present(desc2)) then
-!!$      write(0,*) 'Check on wrk_alloc 2',&
-!!$           & desc2%get_local_rows(), desc%get_local_rows(),&
-!!$           & desc2%get_local_cols(),desc%get_local_cols()
-!!$      flush(0)
-      if (desc2%get_local_cols()>desc%get_local_cols()) then
-        call psb_geasb(wk%vx2l,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vy2l,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vtx,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vty,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        allocate(wk%wv(nwv),stat=info)
-        do i=1,nwv
-          call psb_geasb(wk%wv(i),desc2,info,&
-               & scratch=.true.,mold=vmold)
-        end do
-      else
-!!$        write(0,*) 'Check on wrk_alloc 1.5 ',&
-!!$             & desc%get_local_rows(),&
-!!$             & desc%get_local_cols()
-        call psb_geasb(wk%vx2l,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vy2l,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vtx,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vty,desc,info,&
-             & scratch=.true.,mold=vmold)
-        allocate(wk%wv(nwv),stat=info)
-        do i=1,nwv
-          call psb_geasb(wk%wv(i),desc,info,&
-               & scratch=.true.,mold=vmold)
-        end do
-      end if
-    else
-!!$      write(0,*) 'Check on wrk_alloc 1 ',&
-!!$           & desc%get_local_rows(),&
-!!$           & desc%get_local_cols()
-      call psb_geasb(wk%vx2l,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vy2l,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vtx,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vty,desc,info,&
-           & scratch=.true.,mold=vmold)
-      allocate(wk%wv(nwv),stat=info)
-      do i=1,nwv
-        call psb_geasb(wk%wv(i),desc,info,&
-             & scratch=.true.,mold=vmold)
-      end do
-    end if
-  end subroutine c_wrk_alloc
-
-  subroutine c_wrk_free(wk,info)
-
-    Implicit None
-
-    ! Arguments
-    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-    info = psb_success_
-
-    if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
-    if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
-    if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
-    if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
-    call wk%vtx%free(info)
-    call wk%vty%free(info)
-    call wk%vx2l%free(info)
-    call wk%vy2l%free(info)
-    if (allocated(wk%wv)) then
-      do i=1,size(wk%wv)
-        call wk%wv(i)%free(info)
-      end do
-      deallocate(wk%wv, stat=info)
-    end if
-
-  end subroutine c_wrk_free
-
-  subroutine c_wrk_clone(wk,wkout,info)
-    use psb_base_mod
-    Implicit None
-
-    ! Arguments
-    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
-    class(amg_cmlprec_wrk_type), target, intent(inout) :: wkout
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-    info = psb_success_
-
-    call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
-    call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
-    call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
-    call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
-    call wk%vtx%clone(wkout%vtx,info)
-    call wk%vty%clone(wkout%vty,info)
-    call wk%vx2l%clone(wkout%vx2l,info)
-    call wk%vy2l%clone(wkout%vy2l,info)
-    if (allocated(wkout%wv)) then
-      do i=1,size(wkout%wv)
-        call wkout%wv(i)%free(info)
-      end do
-      deallocate( wkout%wv)
-    end if
-    allocate(wkout%wv(size(wk%wv)),stat=info)
-    do i=1,size(wk%wv)
-      call wk%wv(i)%clone(wkout%wv(i),info)
-    end do
-    return
-
-  end subroutine c_wrk_clone
-
-  subroutine c_wrk_move_alloc(wk, b,info)
-    implicit none
-    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk, b
-    integer(psb_ipk_), intent(out) :: info
-
-    call b%free(info)
-    call move_alloc(wk%tx,b%tx)
-    call move_alloc(wk%ty,b%ty)
-    call move_alloc(wk%x2l,b%x2l)
-    call move_alloc(wk%y2l,b%y2l)
-    !
-    ! Should define V%move_alloc....
-    call move_alloc(wk%vtx%v,b%vtx%v)
-    call move_alloc(wk%vty%v,b%vty%v)
-    call move_alloc(wk%vx2l%v,b%vx2l%v)
-    call move_alloc(wk%vy2l%v,b%vy2l%v)
-    call move_alloc(wk%wv,b%wv)
-
-  end subroutine c_wrk_move_alloc
-
-  subroutine c_wrk_cnv(wk,info,vmold)
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(out)                    :: info
-    class(psb_c_base_vect_type), intent(in), optional  :: vmold
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-    if (present(vmold)) then
-      call wk%vtx%cnv(vmold)
-      call wk%vty%cnv(vmold)
-      call wk%vx2l%cnv(vmold)
-      call wk%vy2l%cnv(vmold)
-      if (allocated(wk%wv)) then
-        do i=1,size(wk%wv)
-          call wk%wv(i)%cnv(vmold)
-        end do
-      end if
-    end if
-  end subroutine c_wrk_cnv
-
-  function c_wrk_sizeof(wk) result(val)
-    use psb_realloc_mod
-    implicit none
-    class(amg_cmlprec_wrk_type), intent(in) :: wk
-    integer(psb_epk_) :: val
-    integer :: i
-    val = 0
-    val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%tx)
-    val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%ty)
-    val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%x2l)
-    val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%y2l)
-    val = val + wk%vtx%sizeof()
-    val = val + wk%vty%sizeof()
-    val = val + wk%vx2l%sizeof()
-    val = val + wk%vy2l%sizeof()
-    if (allocated(wk%wv)) then
-      do i=1, size(wk%wv)
-        val = val + wk%wv(i)%sizeof()
-      end do
-    end if
-  end function c_wrk_sizeof
-
-  subroutine c_remap_data_clone(rmp, remap_out, info)
-    use psb_base_mod
-    implicit none
-    ! Arguments
-    class(amg_c_remap_data_type), target, intent(inout) :: rmp
-    class(amg_c_remap_data_type), target, intent(inout) :: remap_out
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-
-    call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
-    if (info == psb_success_) &
-         & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
-    remap_out%idest = rmp%idest
-    call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
-    call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
-  end subroutine c_remap_data_clone
-
+  
 end module amg_c_onelev_mod

amgprec/amg_c_prec_type.f90

@@ -102,6 +102,7 @@ module amg_c_prec_type
     ! The multilevel hierarchy
     !
     type(amg_c_onelev_type), allocatable :: precv(:)
+    integer(psb_ipk_)                    :: nlevs
   contains
     procedure, pass(prec)               :: psb_c_apply2_vect => amg_c_apply2_vect
     procedure, pass(prec)               :: psb_c_apply1_vect => amg_c_apply1_vect
@@ -119,6 +120,7 @@ module amg_c_prec_type
     procedure, pass(prec)               :: cmp_complexity => amg_c_cmp_compl
     procedure, pass(prec)               :: get_avg_cr => amg_c_get_avg_cr
     procedure, pass(prec)               :: cmp_avg_cr => amg_c_cmp_avg_cr
+    procedure, pass(prec)               :: set_nlevs  => amg_c_set_nlevs
     procedure, pass(prec)               :: get_nlevs  => amg_c_get_nlevs
     procedure, pass(prec)               :: get_nzeros => amg_c_get_nzeros
     procedure, pass(prec)               :: sizeof => amg_cprec_sizeof
@@ -435,10 +437,19 @@ contains
     class(amg_cprec_type), intent(in) :: prec
     integer(psb_ipk_) :: val
     val = 0
-    if (allocated(prec%precv)) then
-      val = size(prec%precv)
-    end if
+!!$    if (allocated(prec%precv)) then
+!!$      val = size(prec%precv)
+!!$    end if
+    val = prec%nlevs
+!!$    write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv)
   end function amg_c_get_nlevs
+
+  subroutine amg_c_set_nlevs(prec,nl) 
+    implicit none
+    class(amg_cprec_type), intent(inout) :: prec
+    integer(psb_ipk_) :: nl
+    prec%nlevs = nl
+  end subroutine amg_c_set_nlevs
   !
   ! Function returning the size of the amg_prec_type data structure
   ! in bytes or in number of nonzeros of the operator(s) involved.
@@ -509,7 +520,7 @@ contains
 
     real(psb_spk_) :: num, den, nmin
     type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: il
+    integer(psb_ipk_)   :: il,nl
 
     num = -sone
     den = sone
@@ -519,7 +530,10 @@ contains
       num = prec%precv(il)%base_a%get_nzeros()
       if (num >= szero) then
         den = num
-        do il=2,size(prec%precv)
+        nl = prec%get_nlevs()
+!!$        write(0,*) 'Inside cmp_compl ',nl,size(prec%precv)
+        do il=2, nl
+!!$          write(0,*) '                 ',il,associated(prec%precv(il)%base_a)
           num = num + max(0,prec%precv(il)%base_a%get_nzeros())
         end do
       end if
@@ -550,7 +564,6 @@ contains
   end function amg_c_get_avg_cr
 
   subroutine amg_c_cmp_avg_cr(prec)
-
     implicit none
     class(amg_cprec_type), intent(inout) :: prec
 
@@ -558,17 +571,18 @@ contains
     type(psb_ctxt_type) :: ctxt
     integer(psb_ipk_)   :: il, nl, iam, np
 
-
     avgcr = szero
+    nl = prec%get_nlevs()
+    do il=2,nl
+      if (prec%precv(il)%base_desc%is_ok()) then 
+        ctxt = prec%precv(il)%base_desc%get_ctxt()
+        call psb_info(ctxt,iam,np)
+        if (iam >=0)  avgcr = avgcr + max(szero,prec%precv(il)%szratio)
+      end if
+    end do
+    avgcr = avgcr / (nl-1)
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    if (allocated(prec%precv)) then
-      nl = size(prec%precv)
-      do il=2,nl
-        avgcr = avgcr + max(szero,prec%precv(il)%szratio)
-      end do
-      avgcr = avgcr / (nl-1)
-    end if
     call psb_sum(ctxt,avgcr)
     prec%ag_data%avg_cr = avgcr/np
   end subroutine amg_c_cmp_avg_cr
@@ -586,9 +600,7 @@ contains
   !             error code.
   !
   subroutine amg_cprecfree(p,info)
-
     implicit none
-
     ! Arguments
     type(amg_cprec_type), intent(inout) :: p
     integer(psb_ipk_), intent(out)        :: info
@@ -614,9 +626,7 @@ contains
   end subroutine amg_cprecfree
 
   subroutine amg_c_prec_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_cprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -653,9 +663,7 @@ contains
   end subroutine amg_c_prec_free
 
   subroutine amg_c_smoothers_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_cprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -672,7 +680,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      do i=1,size(prec%precv)
+      do i=1,prec%get_nlevs()
         call prec%precv(i)%free_smoothers(info)
       end do
     end if
@@ -686,9 +694,7 @@ contains
   end subroutine amg_c_smoothers_free
 
   subroutine amg_c_hierarchy_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_cprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -715,7 +721,6 @@ contains
 
   end subroutine amg_c_hierarchy_free
 
-
   !
   ! Top level methods.
   !
@@ -780,7 +785,6 @@ contains
 
   end subroutine amg_c_apply1_vect
 
-
   subroutine amg_c_apply2v(prec,x,y,desc_data,info,trans,work)
     implicit none
     type(psb_desc_type),intent(in)    :: desc_data
@@ -845,7 +849,6 @@ contains
   subroutine amg_c_dump(prec,info,istart,iend,iproc,prefix,head,&
        & ac,rp,smoother,solver,tprol,&
        & global_num)
-
     implicit none
     class(amg_cprec_type), intent(in)     :: prec
     integer(psb_ipk_), intent(out)          :: info
@@ -862,7 +865,7 @@ contains
     info = 0
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    iln = size(prec%precv)
+    iln = prec%get_nlevs()
     if (present(istart)) then
       il1 = max(1,istart)
     else
@@ -886,7 +889,6 @@ contains
   end subroutine amg_c_dump
 
   subroutine amg_c_cnv(prec,info,amold,vmold,imold)
-
     implicit none
     class(amg_cprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)       :: info
@@ -898,7 +900,7 @@ contains
 
     info = psb_success_
     if (allocated(prec%precv)) then
-      do i=1,size(prec%precv)
+      do i=1,prec%get_nlevs()
         if (info == psb_success_ ) &
              & call prec%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
       end do
@@ -907,7 +909,6 @@ contains
   end subroutine amg_c_cnv
 
   subroutine amg_c_clone(prec,precout,info)
-
     implicit none
     class(amg_cprec_type), intent(inout) :: prec
     class(psb_cprec_type), intent(inout) :: precout
@@ -919,7 +920,6 @@ contains
   end subroutine amg_c_clone
 
   subroutine amg_c_inner_clone(prec,precout,info)
-
     implicit none
     class(amg_cprec_type), intent(inout)         :: prec
     class(psb_cprec_type), target, intent(inout) :: precout
@@ -935,8 +935,9 @@ contains
       pout%ctxt          = prec%ctxt
       pout%ag_data       = prec%ag_data
       pout%outer_sweeps  = prec%outer_sweeps
+      pout%nlevs         = prec%nlevs
       if (allocated(prec%precv)) then
-        ln = size(prec%precv)
+        ln = prec%get_nlevs()
         allocate(pout%precv(ln),stat=info)
         if (info /= psb_success_) goto 9999
         if (ln >= 1) then
@@ -944,6 +945,7 @@ contains
         end if
         do lev=2, ln
           if (info /= psb_success_) exit
+!!$          write(0,*) 'Inner_clone must be checked and reimplemented! '
           call prec%precv(lev)%clone(pout%precv(lev),info)
           if (info == psb_success_) then
             pout%precv(lev)%base_a       => pout%precv(lev)%ac
@@ -1023,7 +1025,7 @@ contains
     if (psb_errstatus_fatal()) then
       info = psb_err_internal_error_; goto 9999
     end if
-    nlev   = size(prec%precv)
+    nlev   = prec%get_nlevs()
     level = 1
     do level = 1, nlev
       call prec%precv(level)%allocate_wrk(info,vmold=vmold)
@@ -1046,7 +1048,6 @@ contains
   subroutine amg_c_free_wrk(prec,info)
     use psb_base_mod
     implicit none
-
     ! Arguments
     class(amg_cprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -1063,7 +1064,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      nlev   = size(prec%precv)
+      nlev   = prec%get_nlevs()
       do level = 1, nlev
         call prec%precv(level)%free_wrk(info)
       end do

amgprec/amg_config.h.in

@@ -17,8 +17,6 @@
 @CHAVEMUMPS@
 @CHAVEMUMPSMODULES@
 @CHAVEMUMPSINCLUDES@
-@CHAVEMUMPSVERSION@
-@CHAVEMUMPSVERSIONSTRING@
 @CXXMATCHBOXBIT@
 
 

amgprec/amg_d_base_aggregator_mod.f90

@@ -89,7 +89,7 @@ module amg_d_base_aggregator_mod
     procedure, pass(ag) :: bld_tprol   => amg_d_base_aggregator_build_tprol
     procedure, pass(ag) :: mat_bld     => amg_d_base_aggregator_mat_bld
     procedure, pass(ag) :: mat_asb     => amg_d_base_aggregator_mat_asb
-    procedure, pass(ag) :: bld_map     => amg_d_base_aggregator_bld_map
+    procedure, pass(ag) :: bld_linmap  => amg_d_base_aggregator_bld_linmap
     procedure, pass(ag) :: update_next => amg_d_base_aggregator_update_next
     procedure, pass(ag) :: clone       => amg_d_base_aggregator_clone
     procedure, pass(ag) :: free        => amg_d_base_aggregator_free
@@ -458,7 +458,7 @@ contains
   end subroutine amg_d_base_aggregator_mat_asb
 
   !
-  !> Function   bld_map
+  !> Function   bld_linmap
   !! \memberof  amg_d_base_aggregator_type
   !! \brief     Build linear map between hierarchy levels 
   !!
@@ -473,7 +473,7 @@ contains
   !!  \param map       The output map
   !!  \param info    Return code
   !!  
-  subroutine  amg_d_base_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_d_base_aggregator_bld_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
        & op_restr,op_prol,map,info)
     use psb_base_mod
     implicit none
@@ -484,7 +484,7 @@ contains
     type(psb_dlinmap_type), intent(out)    :: map
     integer(psb_ipk_), intent(out)       :: info
     integer(psb_ipk_) :: err_act
-    character(len=20) :: name='d_base_aggregator_bld_map'
+    character(len=20) :: name='d_base_aggregator_bld_linmap'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -508,7 +508,6 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_d_base_aggregator_bld_map
-
+  end subroutine amg_d_base_aggregator_bld_linmap
 
 end module amg_d_base_aggregator_mod

amgprec/amg_d_inner_mod.f90

@@ -67,7 +67,7 @@ module amg_d_inner_mod
   end interface amg_mlprec_bld
 
   interface amg_mlprec_aply
-    subroutine amg_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
+    subroutine amg_dmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info)
       import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
       import :: amg_dprec_type
       implicit none 
@@ -79,7 +79,7 @@ module amg_d_inner_mod
       character,intent(in)               :: trans
       real(psb_dpk_),target             :: work(:)
       integer(psb_ipk_), intent(out)     :: info
-    end subroutine amg_dmlprec_aply
+    end subroutine amg_dmlprec_aply_a
     subroutine amg_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
       import :: psb_dspmat_type, psb_desc_type, &
            & psb_dpk_, psb_d_vect_type, psb_ipk_

amgprec/amg_d_mumps_solver.F90

@@ -420,7 +420,7 @@ subroutine d_mumps_solver_cseti(sv,what,val,info,idx)
   info = psb_success_
   call psb_erractionsave(err_act)
 
-  select case(psb_toupper(trim(what)))
+  select case(psb_toupper(what))
 #if defined(AMG_HAVE_MUMPS)
   case('MUMPS_LOC_GLOB')
     sv%ipar(1) = val
@@ -466,7 +466,7 @@ subroutine d_mumps_solver_csetr(sv,what,val,info,idx)
   info = psb_success_
   call psb_erractionsave(err_act)
 
-  select case(psb_toupper(trim(what)))
+  select case(psb_toupper(what))
 #if defined(AMG_HAVE_MUMPS)
   case('MUMPS_RPAR_ENTRY')
     if(present(idx)) then 

amgprec/amg_d_onelev_mod.f90

@@ -155,13 +155,35 @@ module amg_d_onelev_mod
   private :: d_wrk_alloc, d_wrk_free, &
        & d_wrk_clone, d_wrk_move_alloc, d_wrk_cnv, d_wrk_sizeof
 
+  !
+  ! Remap.
+  !  This keeps track of remapping.
+  !  Logic here is as follows:
+  !  1. AC_PRE_REMAP  need to figure out if we
+  !                really need it.
+  !  2. DESC_AC_PRE_REMAP  contains the descriptor before
+  !                remapping. Meaning that it is possible
+  !                to implement the RESTRICTOR operator by
+  !                 a. Doing LINMAP_U2V onto this one
+  !                 b. For each process, send the data to
+  !                    IDEST.
+  !                This assumes that remapping goes by
+  !                a factor of 2.
+  !                For the PROLONGATOR operators, we first
+  !                use DESC_AC, then split and send onto
+  !                the processes in DESC_AC_PRE_REMAP.
+  !
+  ! To be fixed: what happens if NP the starting processes
+  ! is not an even number? Coordinate with _X_remap in PSBLAS
+  ! 
   type amg_d_remap_data_type
     type(psb_dspmat_type)          :: ac_pre_remap
     type(psb_desc_type)            :: desc_ac_pre_remap
     integer(psb_ipk_)              :: idest
     integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
   contains
-    procedure, pass(rmp) :: clone   => d_remap_data_clone
+    procedure, pass(rmp) :: clone      => d_remap_data_clone
+    procedure, pass(rmp) :: move_alloc => d_remap_move_alloc
   end type amg_d_remap_data_type
 
   type amg_d_onelev_type
@@ -207,7 +229,7 @@ module amg_d_onelev_mod
     procedure, pass(lv) :: get_wrksz => d_base_onelev_get_wrksize
     procedure, pass(lv) :: allocate_wrk   => d_base_onelev_allocate_wrk
     procedure, pass(lv) :: free_wrk       => d_base_onelev_free_wrk
-    procedure, nopass   :: stringval => amg_stringval
+    procedure, nopass   :: stringval  => amg_stringval
     procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc
 
 
@@ -231,9 +253,7 @@ module amg_d_onelev_mod
        & d_base_onelev_free_wrk
 
   interface
-    subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
-      import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_ldspmat_type, psb_lpk_
-      import :: amg_d_onelev_type
+    module subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
       implicit none
       class(amg_d_onelev_type), intent(inout), target :: lv
       type(psb_dspmat_type), intent(in) :: a
@@ -245,10 +265,7 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
-      import :: psb_d_base_sparse_mat, psb_d_base_vect_type, &
-           & psb_i_base_vect_type, psb_dpk_, amg_d_onelev_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       integer(psb_ipk_), intent(out) :: info
@@ -260,10 +277,7 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
-      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
-           & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
       Implicit None
       ! Arguments
       class(amg_d_onelev_type), intent(in)    :: lv
@@ -276,10 +290,8 @@ module amg_d_onelev_mod
   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
+    module subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,&
+         & iout,verbosity, prefix,global) 
       Implicit None
       ! Arguments
       class(amg_d_onelev_type), intent(in)    :: lv
@@ -293,10 +305,7 @@ module amg_d_onelev_mod
   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_, &
-           & psb_d_base_sparse_mat, psb_ipk_, psb_i_base_vect_type
-      ! Arguments
+    module subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
       class(amg_d_onelev_type), intent(inout)            :: lv
       integer(psb_ipk_), intent(out)                     :: info
       class(psb_d_base_sparse_mat), intent(in), optional :: amold
@@ -306,48 +315,32 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_free(lv,info)
-      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
+    module subroutine amg_d_base_onelev_free(lv,info)
       implicit none
-
       class(amg_d_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)                :: info
     end subroutine amg_d_base_onelev_free
   end interface
 
   interface
-    subroutine amg_d_base_onelev_free_smoothers(lv,info)
-      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
+    module subroutine amg_d_base_onelev_free_smoothers(lv,info)
       implicit none
-
       class(amg_d_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)                :: info
     end subroutine amg_d_base_onelev_free_smoothers
   end interface
 
   interface
-    subroutine amg_d_base_onelev_check(lv,info)
-      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
+    module subroutine amg_d_base_onelev_check(lv,info)
       Implicit None
-      ! Arguments
       class(amg_d_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)            :: info
     end subroutine amg_d_base_onelev_check
   end interface
 
   interface
-    subroutine amg_d_base_onelev_setsm(lv,val,info,pos)
-      import :: psb_dpk_, amg_d_onelev_type, amg_d_base_smoother_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_d_base_onelev_setsm(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_d_onelev_type), target, intent(inout) :: lv
       class(amg_d_base_smoother_type), intent(in)     :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -356,12 +349,8 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_setsv(lv,val,info,pos)
-      import :: psb_dpk_, amg_d_onelev_type, amg_d_base_solver_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_d_base_onelev_setsv(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_d_onelev_type), target, intent(inout) :: lv
       class(amg_d_base_solver_type), intent(in)       :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -370,12 +359,8 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_setag(lv,val,info,pos)
-      import :: psb_dpk_, amg_d_onelev_type, amg_d_base_aggregator_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_d_base_onelev_setag(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_d_onelev_type), target, intent(inout) :: lv
       class(amg_d_base_aggregator_type), intent(in)       :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -384,13 +369,8 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
       Implicit None
-
-      ! Arguments
       class(amg_d_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       integer(psb_ipk_), intent(in)             :: val
@@ -401,12 +381,8 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
       Implicit None
-      ! Arguments
       class(amg_d_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       character(len=*), intent(in)              :: val
@@ -417,12 +393,8 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
       Implicit None
-
       class(amg_d_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       real(psb_dpk_), intent(in)                 :: val
@@ -433,11 +405,8 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
+    module subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
          & solver,tprol,global_num)
-      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
       class(amg_d_onelev_type), intent(in) :: lv
       integer(psb_ipk_), intent(in)          :: level
@@ -448,8 +417,7 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
-      import
+    module subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       real(psb_dpk_), intent(in)     :: alpha, beta
@@ -458,8 +426,8 @@ module amg_d_onelev_mod
       integer(psb_ipk_), intent(out) :: info
       real(psb_dpk_), optional       :: work(:)
     end subroutine amg_d_base_onelev_map_rstr_a
-    subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
-      import
+    module subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
+         & work,vtx,vty)
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       real(psb_dpk_), intent(in)           :: alpha, beta
@@ -471,8 +439,7 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
-      import
+    module subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       real(psb_dpk_), intent(in)     :: alpha, beta
@@ -482,8 +449,8 @@ module amg_d_onelev_mod
       real(psb_dpk_), optional          :: work(:)
 
     end subroutine amg_d_base_onelev_map_prol_a
-    subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
-      import
+    module subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
+         & work,vtx,vty)
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       real(psb_dpk_), intent(in)           :: alpha, beta
@@ -494,6 +461,118 @@ module amg_d_onelev_mod
     end subroutine amg_d_base_onelev_map_prol_v
   end interface
 
+  interface 
+    module subroutine d_base_onelev_move_alloc(lv, b,info)
+      implicit none
+      class(amg_d_onelev_type), target, intent(inout) :: lv, b
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine d_base_onelev_move_alloc
+  end interface
+
+  interface 
+    module subroutine d_base_onelev_allocate_wrk(lv,info,vmold)
+      implicit none
+      class(amg_d_onelev_type), target, intent(inout) :: lv
+      integer(psb_ipk_), intent(out) :: info
+      class(psb_d_base_vect_type), intent(in), optional  :: vmold
+    end subroutine d_base_onelev_allocate_wrk
+  end interface
+  
+  interface 
+    module subroutine d_base_onelev_free_wrk(lv,info)
+      implicit none
+      class(amg_d_onelev_type), target, intent(inout) :: lv
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine d_base_onelev_free_wrk
+  end interface
+
+  interface 
+    module  subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
+      Implicit None
+      ! Arguments
+      class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(in)                     :: nwv
+      type(psb_desc_type), intent(in)                   :: desc
+      integer(psb_ipk_), intent(out)                    :: info
+      class(psb_d_base_vect_type), intent(in), optional  :: vmold
+      type(psb_desc_type), intent(in), optional          :: desc2
+    end subroutine d_wrk_alloc
+  end interface
+
+  interface 
+    module subroutine d_inner_do_wrk_alloc(wk,nwv,desc,vmold)
+      class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(in)                     :: nwv
+      type(psb_desc_type), intent(in)                   :: desc
+      class(psb_d_base_vect_type), intent(in), optional  :: vmold
+    end subroutine d_inner_do_wrk_alloc
+  end interface
+
+  interface 
+    module  subroutine d_wrk_free(wk,info)
+      Implicit None
+      ! Arguments
+      class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine d_wrk_free
+  end interface
+
+  interface 
+    module  subroutine d_wrk_clone(wk,wkout,info)
+      Implicit None
+      ! Arguments
+      class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+      class(amg_dmlprec_wrk_type), target, intent(inout) :: wkout
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine d_wrk_clone
+  end interface
+
+  interface 
+    module subroutine d_wrk_move_alloc(wk, b,info)
+      implicit none
+      class(amg_dmlprec_wrk_type), target, intent(inout) :: wk, b
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine d_wrk_move_alloc
+  end interface
+
+  interface
+    module subroutine d_wrk_cnv(wk,info,vmold)
+      Implicit None
+      class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(out)                    :: info
+      class(psb_d_base_vect_type), intent(in), optional  :: vmold
+    end subroutine d_wrk_cnv
+  end interface
+
+  interface
+    module function d_wrk_sizeof(wk) result(val)
+      implicit none
+      class(amg_dmlprec_wrk_type), intent(in) :: wk
+      integer(psb_epk_) :: val
+    end  function d_wrk_sizeof
+  end interface
+
+  interface 
+    module subroutine d_remap_data_clone(rmp, remap_out, info)
+      implicit none
+      ! Arguments
+      class(amg_d_remap_data_type), target, intent(inout) :: rmp
+      class(amg_d_remap_data_type), target, intent(inout) :: remap_out
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine d_remap_data_clone
+  end interface
+
+  interface 
+    module subroutine d_remap_move_alloc(rmp, remap_out, info)
+      implicit none
+      ! Arguments
+      class(amg_d_remap_data_type), target, intent(inout) :: rmp
+      class(amg_d_remap_data_type), target, intent(inout) :: remap_out
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine d_remap_move_alloc
+  end interface
+  
+
 contains
   !
   ! Function returning the size of the amg_prec_type data structure
@@ -619,7 +698,7 @@ contains
     ! Arguments
     class(amg_d_onelev_type), target, intent(inout) :: lv
     class(amg_d_onelev_type), target, intent(inout) :: lvout
-    integer(psb_ipk_), intent(out)                    :: info
+    integer(psb_ipk_), intent(out)                  :: info
 
     info = psb_success_
     if (allocated(lv%sm)) then
@@ -661,36 +740,6 @@ contains
 
   end subroutine d_base_onelev_clone
 
-  subroutine d_base_onelev_move_alloc(lv, b,info)
-    use psb_base_mod
-    implicit none
-    class(amg_d_onelev_type), target, intent(inout) :: lv, b
-    integer(psb_ipk_), intent(out) :: info
-
-    call b%free(info)
-    b%parms  = lv%parms
-    b%szratio = lv%szratio
-    if (associated(lv%sm2,lv%sm2a)) then
-      call move_alloc(lv%sm,b%sm)
-      call move_alloc(lv%sm2a,b%sm2a)
-      b%sm2 =>b%sm2a
-    else
-      call move_alloc(lv%sm,b%sm)
-      call move_alloc(lv%sm2a,b%sm2a)
-      b%sm2 =>b%sm
-    end if
-
-    call move_alloc(lv%aggr,b%aggr)
-    if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
-    if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
-    if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
-    if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
-    b%base_a    => lv%base_a
-    b%base_desc => lv%base_desc
-
-  end subroutine d_base_onelev_move_alloc
-
-
   function d_base_onelev_get_wrksize(lv) result(val)
     implicit none
     class(amg_d_onelev_type), intent(inout) :: lv
@@ -728,269 +777,5 @@ contains
 
   end function d_base_onelev_get_wrksize
 
-  subroutine d_base_onelev_allocate_wrk(lv,info,vmold)
-    use psb_base_mod
-    implicit none
-    class(amg_d_onelev_type), target, intent(inout) :: lv
-    integer(psb_ipk_), intent(out) :: info
-    class(psb_d_base_vect_type), intent(in), optional  :: vmold
-    !
-    integer(psb_ipk_) :: nwv, i
-    info = psb_success_
-    nwv = lv%get_wrksz()
-    if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
-    if (info == 0) then
-      if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
-        !
-        !  Need to fix this, we need two different allocations
-        !
-        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
-             & desc2=lv%remap_data%desc_ac_pre_remap)
-      else
-        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
-      end if
-    end if
-
-  end subroutine d_base_onelev_allocate_wrk
-
-
-  subroutine d_base_onelev_free_wrk(lv,info)
-    use psb_base_mod
-    implicit none
-    class(amg_d_onelev_type), target, intent(inout) :: lv
-    integer(psb_ipk_), intent(out) :: info
-    !
-    integer(psb_ipk_) :: nwv,i
-    info = psb_success_
-
-    if (allocated(lv%wrk)) then
-      call lv%wrk%free(info)
-      if (info == 0) deallocate(lv%wrk,stat=info)
-    end if
-  end subroutine d_base_onelev_free_wrk
-
-  subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(in)                     :: nwv
-    type(psb_desc_type), intent(in)                   :: desc
-    integer(psb_ipk_), intent(out)                    :: info
-    class(psb_d_base_vect_type), intent(in), optional  :: vmold
-    type(psb_desc_type), intent(in), optional          :: desc2
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-    call wk%free(info)
-    if  (present(desc2)) then
-!!$      write(0,*) 'Check on wrk_alloc 2',&
-!!$           & desc2%get_local_rows(), desc%get_local_rows(),&
-!!$           & desc2%get_local_cols(),desc%get_local_cols()
-!!$      flush(0)
-      if (desc2%get_local_cols()>desc%get_local_cols()) then
-        call psb_geasb(wk%vx2l,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vy2l,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vtx,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vty,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        allocate(wk%wv(nwv),stat=info)
-        do i=1,nwv
-          call psb_geasb(wk%wv(i),desc2,info,&
-               & scratch=.true.,mold=vmold)
-        end do
-      else
-!!$        write(0,*) 'Check on wrk_alloc 1.5 ',&
-!!$             & desc%get_local_rows(),&
-!!$             & desc%get_local_cols()
-        call psb_geasb(wk%vx2l,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vy2l,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vtx,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vty,desc,info,&
-             & scratch=.true.,mold=vmold)
-        allocate(wk%wv(nwv),stat=info)
-        do i=1,nwv
-          call psb_geasb(wk%wv(i),desc,info,&
-               & scratch=.true.,mold=vmold)
-        end do
-      end if
-    else
-!!$      write(0,*) 'Check on wrk_alloc 1 ',&
-!!$           & desc%get_local_rows(),&
-!!$           & desc%get_local_cols()
-      call psb_geasb(wk%vx2l,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vy2l,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vtx,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vty,desc,info,&
-           & scratch=.true.,mold=vmold)
-      allocate(wk%wv(nwv),stat=info)
-      do i=1,nwv
-        call psb_geasb(wk%wv(i),desc,info,&
-             & scratch=.true.,mold=vmold)
-      end do
-    end if
-  end subroutine d_wrk_alloc
-
-  subroutine d_wrk_free(wk,info)
-
-    Implicit None
-
-    ! Arguments
-    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-    info = psb_success_
-
-    if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
-    if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
-    if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
-    if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
-    call wk%vtx%free(info)
-    call wk%vty%free(info)
-    call wk%vx2l%free(info)
-    call wk%vy2l%free(info)
-    if (allocated(wk%wv)) then
-      do i=1,size(wk%wv)
-        call wk%wv(i)%free(info)
-      end do
-      deallocate(wk%wv, stat=info)
-    end if
-
-  end subroutine d_wrk_free
-
-  subroutine d_wrk_clone(wk,wkout,info)
-    use psb_base_mod
-    Implicit None
-
-    ! Arguments
-    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
-    class(amg_dmlprec_wrk_type), target, intent(inout) :: wkout
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-    info = psb_success_
-
-    call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
-    call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
-    call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
-    call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
-    call wk%vtx%clone(wkout%vtx,info)
-    call wk%vty%clone(wkout%vty,info)
-    call wk%vx2l%clone(wkout%vx2l,info)
-    call wk%vy2l%clone(wkout%vy2l,info)
-    if (allocated(wkout%wv)) then
-      do i=1,size(wkout%wv)
-        call wkout%wv(i)%free(info)
-      end do
-      deallocate( wkout%wv)
-    end if
-    allocate(wkout%wv(size(wk%wv)),stat=info)
-    do i=1,size(wk%wv)
-      call wk%wv(i)%clone(wkout%wv(i),info)
-    end do
-    return
-
-  end subroutine d_wrk_clone
-
-  subroutine d_wrk_move_alloc(wk, b,info)
-    implicit none
-    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk, b
-    integer(psb_ipk_), intent(out) :: info
-
-    call b%free(info)
-    call move_alloc(wk%tx,b%tx)
-    call move_alloc(wk%ty,b%ty)
-    call move_alloc(wk%x2l,b%x2l)
-    call move_alloc(wk%y2l,b%y2l)
-    !
-    ! Should define V%move_alloc....
-    call move_alloc(wk%vtx%v,b%vtx%v)
-    call move_alloc(wk%vty%v,b%vty%v)
-    call move_alloc(wk%vx2l%v,b%vx2l%v)
-    call move_alloc(wk%vy2l%v,b%vy2l%v)
-    call move_alloc(wk%wv,b%wv)
-
-  end subroutine d_wrk_move_alloc
-
-  subroutine d_wrk_cnv(wk,info,vmold)
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(out)                    :: info
-    class(psb_d_base_vect_type), intent(in), optional  :: vmold
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-    if (present(vmold)) then
-      call wk%vtx%cnv(vmold)
-      call wk%vty%cnv(vmold)
-      call wk%vx2l%cnv(vmold)
-      call wk%vy2l%cnv(vmold)
-      if (allocated(wk%wv)) then
-        do i=1,size(wk%wv)
-          call wk%wv(i)%cnv(vmold)
-        end do
-      end if
-    end if
-  end subroutine d_wrk_cnv
-
-  function d_wrk_sizeof(wk) result(val)
-    use psb_realloc_mod
-    implicit none
-    class(amg_dmlprec_wrk_type), intent(in) :: wk
-    integer(psb_epk_) :: val
-    integer :: i
-    val = 0
-    val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%tx)
-    val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%ty)
-    val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%x2l)
-    val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%y2l)
-    val = val + wk%vtx%sizeof()
-    val = val + wk%vty%sizeof()
-    val = val + wk%vx2l%sizeof()
-    val = val + wk%vy2l%sizeof()
-    if (allocated(wk%wv)) then
-      do i=1, size(wk%wv)
-        val = val + wk%wv(i)%sizeof()
-      end do
-    end if
-  end function d_wrk_sizeof
-
-  subroutine d_remap_data_clone(rmp, remap_out, info)
-    use psb_base_mod
-    implicit none
-    ! Arguments
-    class(amg_d_remap_data_type), target, intent(inout) :: rmp
-    class(amg_d_remap_data_type), target, intent(inout) :: remap_out
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-
-    call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
-    if (info == psb_success_) &
-         & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
-    remap_out%idest = rmp%idest
-    call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
-    call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
-  end subroutine d_remap_data_clone
-
+  
 end module amg_d_onelev_mod

amgprec/amg_d_parmatch_aggregator_mod.F90

@@ -136,7 +136,7 @@ module amg_d_parmatch_aggregator_mod
     procedure, pass(ag) :: mat_bld      => amg_d_parmatch_aggregator_mat_bld
     procedure, pass(ag) :: mat_asb      => amg_d_parmatch_aggregator_mat_asb
     procedure, pass(ag) :: inner_mat_asb      => amg_d_parmatch_aggregator_inner_mat_asb
-    procedure, pass(ag) :: bld_map      => amg_d_parmatch_aggregator_bld_map
+    procedure, pass(ag) :: bld_linmap   => amg_d_parmatch_aggregator_bld_linmap
     procedure, pass(ag) :: csetc        => amg_d_parmatch_aggr_csetc
     procedure, pass(ag) :: cseti        => amg_d_parmatch_aggr_cseti
     procedure, pass(ag) :: default      => amg_d_parmatch_aggr_set_default
@@ -643,7 +643,7 @@ contains
     end select
   end subroutine amg_d_parmatch_aggregator_clone
 
-  subroutine  amg_d_parmatch_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_d_parmatch_aggregator_bld_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
        & op_restr,op_prol,map,info)
     use psb_base_mod
     implicit none
@@ -654,7 +654,7 @@ contains
     type(psb_dlinmap_type), intent(out)     :: map
     integer(psb_ipk_), intent(out)          :: info
     integer(psb_ipk_) :: err_act
-    character(len=20) :: name='d_parmatch_aggregator_bld_map'
+    character(len=20) :: name='d_parmatch_aggregator_bld_linmap'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -680,5 +680,5 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_d_parmatch_aggregator_bld_map
+  end subroutine amg_d_parmatch_aggregator_bld_linmap
 end module amg_d_parmatch_aggregator_mod

amgprec/amg_d_prec_type.f90

@@ -102,6 +102,7 @@ module amg_d_prec_type
     ! The multilevel hierarchy
     !
     type(amg_d_onelev_type), allocatable :: precv(:)
+    integer(psb_ipk_)                    :: nlevs
   contains
     procedure, pass(prec)               :: psb_d_apply2_vect => amg_d_apply2_vect
     procedure, pass(prec)               :: psb_d_apply1_vect => amg_d_apply1_vect
@@ -119,6 +120,7 @@ module amg_d_prec_type
     procedure, pass(prec)               :: cmp_complexity => amg_d_cmp_compl
     procedure, pass(prec)               :: get_avg_cr => amg_d_get_avg_cr
     procedure, pass(prec)               :: cmp_avg_cr => amg_d_cmp_avg_cr
+    procedure, pass(prec)               :: set_nlevs  => amg_d_set_nlevs
     procedure, pass(prec)               :: get_nlevs  => amg_d_get_nlevs
     procedure, pass(prec)               :: get_nzeros => amg_d_get_nzeros
     procedure, pass(prec)               :: sizeof => amg_dprec_sizeof
@@ -435,10 +437,19 @@ contains
     class(amg_dprec_type), intent(in) :: prec
     integer(psb_ipk_) :: val
     val = 0
-    if (allocated(prec%precv)) then
-      val = size(prec%precv)
-    end if
+!!$    if (allocated(prec%precv)) then
+!!$      val = size(prec%precv)
+!!$    end if
+    val = prec%nlevs
+!!$    write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv)
   end function amg_d_get_nlevs
+
+  subroutine amg_d_set_nlevs(prec,nl) 
+    implicit none
+    class(amg_dprec_type), intent(inout) :: prec
+    integer(psb_ipk_) :: nl
+    prec%nlevs = nl
+  end subroutine amg_d_set_nlevs
   !
   ! Function returning the size of the amg_prec_type data structure
   ! in bytes or in number of nonzeros of the operator(s) involved.
@@ -509,7 +520,7 @@ contains
 
     real(psb_dpk_) :: num, den, nmin
     type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: il
+    integer(psb_ipk_)   :: il,nl
 
     num = -done
     den = done
@@ -519,7 +530,10 @@ contains
       num = prec%precv(il)%base_a%get_nzeros()
       if (num >= dzero) then
         den = num
-        do il=2,size(prec%precv)
+        nl = prec%get_nlevs()
+!!$        write(0,*) 'Inside cmp_compl ',nl,size(prec%precv)
+        do il=2, nl
+!!$          write(0,*) '                 ',il,associated(prec%precv(il)%base_a)
           num = num + max(0,prec%precv(il)%base_a%get_nzeros())
         end do
       end if
@@ -550,7 +564,6 @@ contains
   end function amg_d_get_avg_cr
 
   subroutine amg_d_cmp_avg_cr(prec)
-
     implicit none
     class(amg_dprec_type), intent(inout) :: prec
 
@@ -558,17 +571,18 @@ contains
     type(psb_ctxt_type) :: ctxt
     integer(psb_ipk_)   :: il, nl, iam, np
 
-
     avgcr = dzero
+    nl = prec%get_nlevs()
+    do il=2,nl
+      if (prec%precv(il)%base_desc%is_ok()) then 
+        ctxt = prec%precv(il)%base_desc%get_ctxt()
+        call psb_info(ctxt,iam,np)
+        if (iam >=0)  avgcr = avgcr + max(dzero,prec%precv(il)%szratio)
+      end if
+    end do
+    avgcr = avgcr / (nl-1)
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    if (allocated(prec%precv)) then
-      nl = size(prec%precv)
-      do il=2,nl
-        avgcr = avgcr + max(dzero,prec%precv(il)%szratio)
-      end do
-      avgcr = avgcr / (nl-1)
-    end if
     call psb_sum(ctxt,avgcr)
     prec%ag_data%avg_cr = avgcr/np
   end subroutine amg_d_cmp_avg_cr
@@ -586,9 +600,7 @@ contains
   !             error code.
   !
   subroutine amg_dprecfree(p,info)
-
     implicit none
-
     ! Arguments
     type(amg_dprec_type), intent(inout) :: p
     integer(psb_ipk_), intent(out)        :: info
@@ -614,9 +626,7 @@ contains
   end subroutine amg_dprecfree
 
   subroutine amg_d_prec_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_dprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -653,9 +663,7 @@ contains
   end subroutine amg_d_prec_free
 
   subroutine amg_d_smoothers_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_dprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -672,7 +680,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      do i=1,size(prec%precv)
+      do i=1,prec%get_nlevs()
         call prec%precv(i)%free_smoothers(info)
       end do
     end if
@@ -686,9 +694,7 @@ contains
   end subroutine amg_d_smoothers_free
 
   subroutine amg_d_hierarchy_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_dprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -715,7 +721,6 @@ contains
 
   end subroutine amg_d_hierarchy_free
 
-
   !
   ! Top level methods.
   !
@@ -780,7 +785,6 @@ contains
 
   end subroutine amg_d_apply1_vect
 
-
   subroutine amg_d_apply2v(prec,x,y,desc_data,info,trans,work)
     implicit none
     type(psb_desc_type),intent(in)    :: desc_data
@@ -845,7 +849,6 @@ contains
   subroutine amg_d_dump(prec,info,istart,iend,iproc,prefix,head,&
        & ac,rp,smoother,solver,tprol,&
        & global_num)
-
     implicit none
     class(amg_dprec_type), intent(in)     :: prec
     integer(psb_ipk_), intent(out)          :: info
@@ -862,7 +865,7 @@ contains
     info = 0
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    iln = size(prec%precv)
+    iln = prec%get_nlevs()
     if (present(istart)) then
       il1 = max(1,istart)
     else
@@ -886,7 +889,6 @@ contains
   end subroutine amg_d_dump
 
   subroutine amg_d_cnv(prec,info,amold,vmold,imold)
-
     implicit none
     class(amg_dprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)       :: info
@@ -898,7 +900,7 @@ contains
 
     info = psb_success_
     if (allocated(prec%precv)) then
-      do i=1,size(prec%precv)
+      do i=1,prec%get_nlevs()
         if (info == psb_success_ ) &
              & call prec%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
       end do
@@ -907,7 +909,6 @@ contains
   end subroutine amg_d_cnv
 
   subroutine amg_d_clone(prec,precout,info)
-
     implicit none
     class(amg_dprec_type), intent(inout) :: prec
     class(psb_dprec_type), intent(inout) :: precout
@@ -919,7 +920,6 @@ contains
   end subroutine amg_d_clone
 
   subroutine amg_d_inner_clone(prec,precout,info)
-
     implicit none
     class(amg_dprec_type), intent(inout)         :: prec
     class(psb_dprec_type), target, intent(inout) :: precout
@@ -935,8 +935,9 @@ contains
       pout%ctxt          = prec%ctxt
       pout%ag_data       = prec%ag_data
       pout%outer_sweeps  = prec%outer_sweeps
+      pout%nlevs         = prec%nlevs
       if (allocated(prec%precv)) then
-        ln = size(prec%precv)
+        ln = prec%get_nlevs()
         allocate(pout%precv(ln),stat=info)
         if (info /= psb_success_) goto 9999
         if (ln >= 1) then
@@ -944,6 +945,7 @@ contains
         end if
         do lev=2, ln
           if (info /= psb_success_) exit
+!!$          write(0,*) 'Inner_clone must be checked and reimplemented! '
           call prec%precv(lev)%clone(pout%precv(lev),info)
           if (info == psb_success_) then
             pout%precv(lev)%base_a       => pout%precv(lev)%ac
@@ -1023,7 +1025,7 @@ contains
     if (psb_errstatus_fatal()) then
       info = psb_err_internal_error_; goto 9999
     end if
-    nlev   = size(prec%precv)
+    nlev   = prec%get_nlevs()
     level = 1
     do level = 1, nlev
       call prec%precv(level)%allocate_wrk(info,vmold=vmold)
@@ -1046,7 +1048,6 @@ contains
   subroutine amg_d_free_wrk(prec,info)
     use psb_base_mod
     implicit none
-
     ! Arguments
     class(amg_dprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -1063,7 +1064,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      nlev   = size(prec%precv)
+      nlev   = prec%get_nlevs()
       do level = 1, nlev
         call prec%precv(level)%free_wrk(info)
       end do

amgprec/amg_d_richards_smoother.f90

@@ -1,365 +0,0 @@
-!
-!
-!                             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 prior written permission.
-!
-!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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_richards_smoother.f90
-!
-! Module: amg_d_richards_smoother
-!
-!  This module defines:
-!    the amg_d_richards_smoother_type data structure containing the
-!    smoother for a preconditioned Richards iteration.
-!  The smoother applies the iterative method:
-!    x_{k+1} = x_k + omega * P^{-1} * (b - A * x_k)
-!  where P is a preconditioner (the solver component) acting on the global matrix A.
-!  This allows using distributed solvers like MUMPS on the full system.
-!
-module amg_d_richards_smoother
-
-  use amg_d_base_smoother_mod
-
-  type, extends(amg_d_base_smoother_type) :: amg_d_richards_smoother_type
-    ! The local solver component is inherited from the
-    ! parent type, but acts on the global matrix.
-    !    class(amg_d_base_solver_type), allocatable :: sv
-    !
-    type(psb_dspmat_type), pointer  :: pa => null()
-    integer(psb_lpk_)               :: global_nnz_tot
-    logical                         :: checkres
-    logical                         :: printres
-    integer(psb_ipk_)               :: checkiter
-    integer(psb_ipk_)               :: printiter
-    real(psb_dpk_)                  :: tol
-    real(psb_dpk_)                  :: omega
-  contains
-    procedure, pass(sm) :: apply_v => amg_d_richards_smoother_apply_vect
-    procedure, pass(sm) :: apply_a => amg_d_richards_smoother_apply
-    procedure, pass(sm) :: dump    => amg_d_richards_smoother_dmp
-    procedure, pass(sm) :: build   => amg_d_richards_smoother_bld
-    procedure, pass(sm) :: cnv     => amg_d_richards_smoother_cnv
-    procedure, pass(sm) :: clone   => amg_d_richards_smoother_clone
-    procedure, pass(sm) :: clone_settings => amg_d_richards_smoother_clone_settings
-    procedure, pass(sm) :: clear_data     => amg_d_richards_smoother_clear_data
-    procedure, pass(sm) :: free    => d_richards_smoother_free
-    procedure, pass(sm) :: cseti   => amg_d_richards_smoother_cseti
-    procedure, pass(sm) :: csetc   => amg_d_richards_smoother_csetc
-    procedure, pass(sm) :: csetr   => amg_d_richards_smoother_csetr
-    procedure, pass(sm) :: descr   => amg_d_richards_smoother_descr
-    procedure, pass(sm) :: sizeof  => d_richards_smoother_sizeof
-    procedure, pass(sm) :: default => d_richards_smoother_default
-    procedure, pass(sm) :: get_nzeros => d_richards_smoother_get_nzeros
-    procedure, pass(sm) :: get_wrksz => d_richards_smoother_get_wrksize
-    procedure, nopass   :: get_fmt    => d_richards_smoother_get_fmt
-    procedure, nopass   :: get_id     => d_richards_smoother_get_id
-  end type amg_d_richards_smoother_type
-
-  private :: d_richards_smoother_free, &
-       & d_richards_smoother_sizeof, d_richards_smoother_get_nzeros, &
-       & d_richards_smoother_get_fmt, d_richards_smoother_get_id, &
-       & d_richards_smoother_get_wrksize
-
-  interface
-    subroutine amg_d_richards_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
-         & sweeps,work,wv,info,init,initu)
-      import :: psb_desc_type, amg_d_richards_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_richards_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_richards_smoother_apply_vect
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
-         & sweeps,work,info,init,initu)
-      import :: psb_desc_type, amg_d_richards_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_richards_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_richards_smoother_apply
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
-      import :: psb_desc_type, amg_d_richards_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(inout), target        :: a
-      Type(psb_desc_type), Intent(inout)                  :: desc_a
-      class(amg_d_richards_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_richards_smoother_bld
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_cnv(sm,info,amold,vmold,imold)
-      import :: amg_d_richards_smoother_type, psb_dpk_, &
-           & psb_d_base_sparse_mat, psb_d_base_vect_type,&
-           & psb_ipk_, psb_i_base_vect_type
-      class(amg_d_richards_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_richards_smoother_cnv
-  end interface
-
-  interface
-    subroutine amg_d_richards_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_richards_smoother_type, psb_epk_, psb_desc_type, &
-           & psb_ipk_
-      implicit none
-      class(amg_d_richards_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_richards_smoother_dmp
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_clone(sm,smout,info)
-      import :: amg_d_richards_smoother_type, psb_dpk_, &
-           & amg_d_base_smoother_type, psb_ipk_
-      class(amg_d_richards_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_richards_smoother_clone
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_clone_settings(sm,smout,info)
-      import :: amg_d_richards_smoother_type, psb_dpk_, &
-           & amg_d_base_smoother_type, psb_ipk_
-      class(amg_d_richards_smoother_type), intent(inout)  :: sm
-      class(amg_d_base_smoother_type), intent(inout) :: smout
-      integer(psb_ipk_), intent(out)                :: info
-    end subroutine amg_d_richards_smoother_clone_settings
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_clear_data(sm,info)
-      import :: amg_d_richards_smoother_type, psb_dpk_, &
-           & amg_d_base_smoother_type, psb_ipk_
-      class(amg_d_richards_smoother_type), intent(inout)               :: sm
-      integer(psb_ipk_), intent(out)                :: info
-    end subroutine amg_d_richards_smoother_clear_data
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_descr(sm,info,iout,coarse,prefix)
-      import :: amg_d_richards_smoother_type, psb_ipk_
-      class(amg_d_richards_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_richards_smoother_descr
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_cseti(sm,what,val,info,idx)
-      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
-           & psb_dpk_, amg_d_richards_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
-      implicit none
-      class(amg_d_richards_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_richards_smoother_cseti
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_csetc(sm,what,val,info,idx)
-      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
-           & psb_dpk_, amg_d_richards_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
-      implicit none
-      class(amg_d_richards_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_richards_smoother_csetc
-  end interface
-
-  interface
-    subroutine amg_d_richards_smoother_csetr(sm,what,val,info,idx)
-      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
-           & psb_dpk_, amg_d_richards_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
-      implicit none
-      class(amg_d_richards_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_richards_smoother_csetr
-  end interface
-
-contains
-
-  subroutine d_richards_smoother_free(sm,info)
-    Implicit None
-
-    ! Arguments
-    class(amg_d_richards_smoother_type), intent(inout) :: sm
-    integer(psb_ipk_), intent(out)                  :: info
-    integer(psb_ipk_) :: err_act
-    character(len=20)  :: name='d_richards_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
-    sm%pa => null()
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-  end subroutine d_richards_smoother_free
-
-  function d_richards_smoother_sizeof(sm) result(val)
-    implicit none
-    ! Arguments
-    class(amg_d_richards_smoother_type), intent(in) :: sm
-    integer(psb_epk_) :: val
-    integer(psb_ipk_)        :: i
-
-    val = psb_sizeof_lp
-    if (allocated(sm%sv)) val = val + sm%sv%sizeof()
-
-    return
-  end function d_richards_smoother_sizeof
-
-  subroutine d_richards_smoother_default(sm)
-    Implicit None
-
-    ! Arguments
-    class(amg_d_richards_smoother_type), intent(inout) :: sm
-
-    !
-    ! Default: Richards iteration with omega=1.0 and no residual check
-    !
-    sm%checkres = .false.
-    sm%printres = .false.
-    sm%checkiter = -1
-    sm%printiter = -1
-    sm%tol = 0
-    sm%omega = 1.0d0
-
-    if (allocated(sm%sv)) then
-      call sm%sv%default()
-    end if
-
-    return
-  end subroutine d_richards_smoother_default
-
-  function d_richards_smoother_get_nzeros(sm) result(val)
-    implicit none
-    ! Arguments
-    class(amg_d_richards_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_richards_smoother_get_nzeros
-
-  function d_richards_smoother_get_wrksize(sm) result(val)
-    implicit none
-    class(amg_d_richards_smoother_type), intent(inout) :: sm
-    integer(psb_ipk_)  :: val
-
-    ! apply_vect uses tx, ty, tz mapped to wv(1:3)
-    val = 3
-    if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
-
-  end function d_richards_smoother_get_wrksize
-
-  function d_richards_smoother_get_fmt() result(val)
-    implicit none
-    character(len=32)  :: val
-
-    val = "Richards smoother"
-  end function d_richards_smoother_get_fmt
-
-  function d_richards_smoother_get_id() result(val)
-    implicit none
-    integer(psb_ipk_)  :: val
-
-    val = amg_richardson_
-  end function d_richards_smoother_get_id
-
-end module amg_d_richards_smoother

amgprec/amg_s_base_aggregator_mod.f90

@@ -89,7 +89,7 @@ module amg_s_base_aggregator_mod
     procedure, pass(ag) :: bld_tprol   => amg_s_base_aggregator_build_tprol
     procedure, pass(ag) :: mat_bld     => amg_s_base_aggregator_mat_bld
     procedure, pass(ag) :: mat_asb     => amg_s_base_aggregator_mat_asb
-    procedure, pass(ag) :: bld_map     => amg_s_base_aggregator_bld_map
+    procedure, pass(ag) :: bld_linmap  => amg_s_base_aggregator_bld_linmap
     procedure, pass(ag) :: update_next => amg_s_base_aggregator_update_next
     procedure, pass(ag) :: clone       => amg_s_base_aggregator_clone
     procedure, pass(ag) :: free        => amg_s_base_aggregator_free
@@ -458,7 +458,7 @@ contains
   end subroutine amg_s_base_aggregator_mat_asb
 
   !
-  !> Function   bld_map
+  !> Function   bld_linmap
   !! \memberof  amg_s_base_aggregator_type
   !! \brief     Build linear map between hierarchy levels 
   !!
@@ -473,7 +473,7 @@ contains
   !!  \param map       The output map
   !!  \param info    Return code
   !!  
-  subroutine  amg_s_base_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_s_base_aggregator_bld_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
        & op_restr,op_prol,map,info)
     use psb_base_mod
     implicit none
@@ -484,7 +484,7 @@ contains
     type(psb_slinmap_type), intent(out)    :: map
     integer(psb_ipk_), intent(out)       :: info
     integer(psb_ipk_) :: err_act
-    character(len=20) :: name='s_base_aggregator_bld_map'
+    character(len=20) :: name='s_base_aggregator_bld_linmap'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -508,7 +508,6 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_s_base_aggregator_bld_map
-
+  end subroutine amg_s_base_aggregator_bld_linmap
 
 end module amg_s_base_aggregator_mod

amgprec/amg_s_inner_mod.f90

@@ -67,7 +67,7 @@ module amg_s_inner_mod
   end interface amg_mlprec_bld
 
   interface amg_mlprec_aply
-    subroutine amg_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
+    subroutine amg_smlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info)
       import :: psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_
       import :: amg_sprec_type
       implicit none 
@@ -79,7 +79,7 @@ module amg_s_inner_mod
       character,intent(in)               :: trans
       real(psb_spk_),target             :: work(:)
       integer(psb_ipk_), intent(out)     :: info
-    end subroutine amg_smlprec_aply
+    end subroutine amg_smlprec_aply_a
     subroutine amg_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
       import :: psb_sspmat_type, psb_desc_type, &
            & psb_spk_, psb_s_vect_type, psb_ipk_

amgprec/amg_s_onelev_mod.f90

@@ -155,13 +155,35 @@ module amg_s_onelev_mod
   private :: s_wrk_alloc, s_wrk_free, &
        & s_wrk_clone, s_wrk_move_alloc, s_wrk_cnv, s_wrk_sizeof
 
+  !
+  ! Remap.
+  !  This keeps track of remapping.
+  !  Logic here is as follows:
+  !  1. AC_PRE_REMAP  need to figure out if we
+  !                really need it.
+  !  2. DESC_AC_PRE_REMAP  contains the descriptor before
+  !                remapping. Meaning that it is possible
+  !                to implement the RESTRICTOR operator by
+  !                 a. Doing LINMAP_U2V onto this one
+  !                 b. For each process, send the data to
+  !                    IDEST.
+  !                This assumes that remapping goes by
+  !                a factor of 2.
+  !                For the PROLONGATOR operators, we first
+  !                use DESC_AC, then split and send onto
+  !                the processes in DESC_AC_PRE_REMAP.
+  !
+  ! To be fixed: what happens if NP the starting processes
+  ! is not an even number? Coordinate with _X_remap in PSBLAS
+  ! 
   type amg_s_remap_data_type
     type(psb_sspmat_type)          :: ac_pre_remap
     type(psb_desc_type)            :: desc_ac_pre_remap
     integer(psb_ipk_)              :: idest
     integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
   contains
-    procedure, pass(rmp) :: clone   => s_remap_data_clone
+    procedure, pass(rmp) :: clone      => s_remap_data_clone
+    procedure, pass(rmp) :: move_alloc => s_remap_move_alloc
   end type amg_s_remap_data_type
 
   type amg_s_onelev_type
@@ -207,7 +229,7 @@ module amg_s_onelev_mod
     procedure, pass(lv) :: get_wrksz => s_base_onelev_get_wrksize
     procedure, pass(lv) :: allocate_wrk   => s_base_onelev_allocate_wrk
     procedure, pass(lv) :: free_wrk       => s_base_onelev_free_wrk
-    procedure, nopass   :: stringval => amg_stringval
+    procedure, nopass   :: stringval  => amg_stringval
     procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc
 
 
@@ -231,9 +253,7 @@ module amg_s_onelev_mod
        & s_base_onelev_free_wrk
 
   interface
-    subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
-      import :: psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lsspmat_type, psb_lpk_
-      import :: amg_s_onelev_type
+    module subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
       implicit none
       class(amg_s_onelev_type), intent(inout), target :: lv
       type(psb_sspmat_type), intent(in) :: a
@@ -245,10 +265,7 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
-      import :: psb_s_base_sparse_mat, psb_s_base_vect_type, &
-           & psb_i_base_vect_type, psb_spk_, amg_s_onelev_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       integer(psb_ipk_), intent(out) :: info
@@ -260,10 +277,7 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
-      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
-           & psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
       Implicit None
       ! Arguments
       class(amg_s_onelev_type), intent(in)    :: lv
@@ -276,10 +290,8 @@ module amg_s_onelev_mod
   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
+    module subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,&
+         & iout,verbosity, prefix,global) 
       Implicit None
       ! Arguments
       class(amg_s_onelev_type), intent(in)    :: lv
@@ -293,10 +305,7 @@ module amg_s_onelev_mod
   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_, &
-           & psb_s_base_sparse_mat, psb_ipk_, psb_i_base_vect_type
-      ! Arguments
+    module subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
       class(amg_s_onelev_type), intent(inout)            :: lv
       integer(psb_ipk_), intent(out)                     :: info
       class(psb_s_base_sparse_mat), intent(in), optional :: amold
@@ -306,48 +315,32 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_free(lv,info)
-      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
+    module subroutine amg_s_base_onelev_free(lv,info)
       implicit none
-
       class(amg_s_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)                :: info
     end subroutine amg_s_base_onelev_free
   end interface
 
   interface
-    subroutine amg_s_base_onelev_free_smoothers(lv,info)
-      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
+    module subroutine amg_s_base_onelev_free_smoothers(lv,info)
       implicit none
-
       class(amg_s_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)                :: info
     end subroutine amg_s_base_onelev_free_smoothers
   end interface
 
   interface
-    subroutine amg_s_base_onelev_check(lv,info)
-      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
+    module subroutine amg_s_base_onelev_check(lv,info)
       Implicit None
-      ! Arguments
       class(amg_s_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)            :: info
     end subroutine amg_s_base_onelev_check
   end interface
 
   interface
-    subroutine amg_s_base_onelev_setsm(lv,val,info,pos)
-      import :: psb_spk_, amg_s_onelev_type, amg_s_base_smoother_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_s_base_onelev_setsm(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_s_onelev_type), target, intent(inout) :: lv
       class(amg_s_base_smoother_type), intent(in)     :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -356,12 +349,8 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_setsv(lv,val,info,pos)
-      import :: psb_spk_, amg_s_onelev_type, amg_s_base_solver_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_s_base_onelev_setsv(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_s_onelev_type), target, intent(inout) :: lv
       class(amg_s_base_solver_type), intent(in)       :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -370,12 +359,8 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_setag(lv,val,info,pos)
-      import :: psb_spk_, amg_s_onelev_type, amg_s_base_aggregator_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_s_base_onelev_setag(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_s_onelev_type), target, intent(inout) :: lv
       class(amg_s_base_aggregator_type), intent(in)       :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -384,13 +369,8 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx)
       Implicit None
-
-      ! Arguments
       class(amg_s_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       integer(psb_ipk_), intent(in)             :: val
@@ -401,12 +381,8 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
       Implicit None
-      ! Arguments
       class(amg_s_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       character(len=*), intent(in)              :: val
@@ -417,12 +393,8 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx)
       Implicit None
-
       class(amg_s_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       real(psb_spk_), intent(in)                 :: val
@@ -433,11 +405,8 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
+    module subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
          & solver,tprol,global_num)
-      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
       class(amg_s_onelev_type), intent(in) :: lv
       integer(psb_ipk_), intent(in)          :: level
@@ -448,8 +417,7 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
-      import
+    module subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       real(psb_spk_), intent(in)     :: alpha, beta
@@ -458,8 +426,8 @@ module amg_s_onelev_mod
       integer(psb_ipk_), intent(out) :: info
       real(psb_spk_), optional       :: work(:)
     end subroutine amg_s_base_onelev_map_rstr_a
-    subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
-      import
+    module subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
+         & work,vtx,vty)
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       real(psb_spk_), intent(in)           :: alpha, beta
@@ -471,8 +439,7 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
-      import
+    module subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       real(psb_spk_), intent(in)     :: alpha, beta
@@ -482,8 +449,8 @@ module amg_s_onelev_mod
       real(psb_spk_), optional          :: work(:)
 
     end subroutine amg_s_base_onelev_map_prol_a
-    subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
-      import
+    module subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
+         & work,vtx,vty)
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       real(psb_spk_), intent(in)           :: alpha, beta
@@ -494,6 +461,118 @@ module amg_s_onelev_mod
     end subroutine amg_s_base_onelev_map_prol_v
   end interface
 
+  interface 
+    module subroutine s_base_onelev_move_alloc(lv, b,info)
+      implicit none
+      class(amg_s_onelev_type), target, intent(inout) :: lv, b
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine s_base_onelev_move_alloc
+  end interface
+
+  interface 
+    module subroutine s_base_onelev_allocate_wrk(lv,info,vmold)
+      implicit none
+      class(amg_s_onelev_type), target, intent(inout) :: lv
+      integer(psb_ipk_), intent(out) :: info
+      class(psb_s_base_vect_type), intent(in), optional  :: vmold
+    end subroutine s_base_onelev_allocate_wrk
+  end interface
+  
+  interface 
+    module subroutine s_base_onelev_free_wrk(lv,info)
+      implicit none
+      class(amg_s_onelev_type), target, intent(inout) :: lv
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine s_base_onelev_free_wrk
+  end interface
+
+  interface 
+    module  subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
+      Implicit None
+      ! Arguments
+      class(amg_smlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(in)                     :: nwv
+      type(psb_desc_type), intent(in)                   :: desc
+      integer(psb_ipk_), intent(out)                    :: info
+      class(psb_s_base_vect_type), intent(in), optional  :: vmold
+      type(psb_desc_type), intent(in), optional          :: desc2
+    end subroutine s_wrk_alloc
+  end interface
+
+  interface 
+    module subroutine s_inner_do_wrk_alloc(wk,nwv,desc,vmold)
+      class(amg_smlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(in)                     :: nwv
+      type(psb_desc_type), intent(in)                   :: desc
+      class(psb_s_base_vect_type), intent(in), optional  :: vmold
+    end subroutine s_inner_do_wrk_alloc
+  end interface
+
+  interface 
+    module  subroutine s_wrk_free(wk,info)
+      Implicit None
+      ! Arguments
+      class(amg_smlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine s_wrk_free
+  end interface
+
+  interface 
+    module  subroutine s_wrk_clone(wk,wkout,info)
+      Implicit None
+      ! Arguments
+      class(amg_smlprec_wrk_type), target, intent(inout) :: wk
+      class(amg_smlprec_wrk_type), target, intent(inout) :: wkout
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine s_wrk_clone
+  end interface
+
+  interface 
+    module subroutine s_wrk_move_alloc(wk, b,info)
+      implicit none
+      class(amg_smlprec_wrk_type), target, intent(inout) :: wk, b
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine s_wrk_move_alloc
+  end interface
+
+  interface
+    module subroutine s_wrk_cnv(wk,info,vmold)
+      Implicit None
+      class(amg_smlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(out)                    :: info
+      class(psb_s_base_vect_type), intent(in), optional  :: vmold
+    end subroutine s_wrk_cnv
+  end interface
+
+  interface
+    module function s_wrk_sizeof(wk) result(val)
+      implicit none
+      class(amg_smlprec_wrk_type), intent(in) :: wk
+      integer(psb_epk_) :: val
+    end  function s_wrk_sizeof
+  end interface
+
+  interface 
+    module subroutine s_remap_data_clone(rmp, remap_out, info)
+      implicit none
+      ! Arguments
+      class(amg_s_remap_data_type), target, intent(inout) :: rmp
+      class(amg_s_remap_data_type), target, intent(inout) :: remap_out
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine s_remap_data_clone
+  end interface
+
+  interface 
+    module subroutine s_remap_move_alloc(rmp, remap_out, info)
+      implicit none
+      ! Arguments
+      class(amg_s_remap_data_type), target, intent(inout) :: rmp
+      class(amg_s_remap_data_type), target, intent(inout) :: remap_out
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine s_remap_move_alloc
+  end interface
+  
+
 contains
   !
   ! Function returning the size of the amg_prec_type data structure
@@ -619,7 +698,7 @@ contains
     ! Arguments
     class(amg_s_onelev_type), target, intent(inout) :: lv
     class(amg_s_onelev_type), target, intent(inout) :: lvout
-    integer(psb_ipk_), intent(out)                    :: info
+    integer(psb_ipk_), intent(out)                  :: info
 
     info = psb_success_
     if (allocated(lv%sm)) then
@@ -661,36 +740,6 @@ contains
 
   end subroutine s_base_onelev_clone
 
-  subroutine s_base_onelev_move_alloc(lv, b,info)
-    use psb_base_mod
-    implicit none
-    class(amg_s_onelev_type), target, intent(inout) :: lv, b
-    integer(psb_ipk_), intent(out) :: info
-
-    call b%free(info)
-    b%parms  = lv%parms
-    b%szratio = lv%szratio
-    if (associated(lv%sm2,lv%sm2a)) then
-      call move_alloc(lv%sm,b%sm)
-      call move_alloc(lv%sm2a,b%sm2a)
-      b%sm2 =>b%sm2a
-    else
-      call move_alloc(lv%sm,b%sm)
-      call move_alloc(lv%sm2a,b%sm2a)
-      b%sm2 =>b%sm
-    end if
-
-    call move_alloc(lv%aggr,b%aggr)
-    if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
-    if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
-    if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
-    if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
-    b%base_a    => lv%base_a
-    b%base_desc => lv%base_desc
-
-  end subroutine s_base_onelev_move_alloc
-
-
   function s_base_onelev_get_wrksize(lv) result(val)
     implicit none
     class(amg_s_onelev_type), intent(inout) :: lv
@@ -728,269 +777,5 @@ contains
 
   end function s_base_onelev_get_wrksize
 
-  subroutine s_base_onelev_allocate_wrk(lv,info,vmold)
-    use psb_base_mod
-    implicit none
-    class(amg_s_onelev_type), target, intent(inout) :: lv
-    integer(psb_ipk_), intent(out) :: info
-    class(psb_s_base_vect_type), intent(in), optional  :: vmold
-    !
-    integer(psb_ipk_) :: nwv, i
-    info = psb_success_
-    nwv = lv%get_wrksz()
-    if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
-    if (info == 0) then
-      if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
-        !
-        !  Need to fix this, we need two different allocations
-        !
-        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
-             & desc2=lv%remap_data%desc_ac_pre_remap)
-      else
-        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
-      end if
-    end if
-
-  end subroutine s_base_onelev_allocate_wrk
-
-
-  subroutine s_base_onelev_free_wrk(lv,info)
-    use psb_base_mod
-    implicit none
-    class(amg_s_onelev_type), target, intent(inout) :: lv
-    integer(psb_ipk_), intent(out) :: info
-    !
-    integer(psb_ipk_) :: nwv,i
-    info = psb_success_
-
-    if (allocated(lv%wrk)) then
-      call lv%wrk%free(info)
-      if (info == 0) deallocate(lv%wrk,stat=info)
-    end if
-  end subroutine s_base_onelev_free_wrk
-
-  subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(amg_smlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(in)                     :: nwv
-    type(psb_desc_type), intent(in)                   :: desc
-    integer(psb_ipk_), intent(out)                    :: info
-    class(psb_s_base_vect_type), intent(in), optional  :: vmold
-    type(psb_desc_type), intent(in), optional          :: desc2
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-    call wk%free(info)
-    if  (present(desc2)) then
-!!$      write(0,*) 'Check on wrk_alloc 2',&
-!!$           & desc2%get_local_rows(), desc%get_local_rows(),&
-!!$           & desc2%get_local_cols(),desc%get_local_cols()
-!!$      flush(0)
-      if (desc2%get_local_cols()>desc%get_local_cols()) then
-        call psb_geasb(wk%vx2l,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vy2l,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vtx,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vty,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        allocate(wk%wv(nwv),stat=info)
-        do i=1,nwv
-          call psb_geasb(wk%wv(i),desc2,info,&
-               & scratch=.true.,mold=vmold)
-        end do
-      else
-!!$        write(0,*) 'Check on wrk_alloc 1.5 ',&
-!!$             & desc%get_local_rows(),&
-!!$             & desc%get_local_cols()
-        call psb_geasb(wk%vx2l,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vy2l,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vtx,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vty,desc,info,&
-             & scratch=.true.,mold=vmold)
-        allocate(wk%wv(nwv),stat=info)
-        do i=1,nwv
-          call psb_geasb(wk%wv(i),desc,info,&
-               & scratch=.true.,mold=vmold)
-        end do
-      end if
-    else
-!!$      write(0,*) 'Check on wrk_alloc 1 ',&
-!!$           & desc%get_local_rows(),&
-!!$           & desc%get_local_cols()
-      call psb_geasb(wk%vx2l,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vy2l,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vtx,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vty,desc,info,&
-           & scratch=.true.,mold=vmold)
-      allocate(wk%wv(nwv),stat=info)
-      do i=1,nwv
-        call psb_geasb(wk%wv(i),desc,info,&
-             & scratch=.true.,mold=vmold)
-      end do
-    end if
-  end subroutine s_wrk_alloc
-
-  subroutine s_wrk_free(wk,info)
-
-    Implicit None
-
-    ! Arguments
-    class(amg_smlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-    info = psb_success_
-
-    if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
-    if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
-    if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
-    if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
-    call wk%vtx%free(info)
-    call wk%vty%free(info)
-    call wk%vx2l%free(info)
-    call wk%vy2l%free(info)
-    if (allocated(wk%wv)) then
-      do i=1,size(wk%wv)
-        call wk%wv(i)%free(info)
-      end do
-      deallocate(wk%wv, stat=info)
-    end if
-
-  end subroutine s_wrk_free
-
-  subroutine s_wrk_clone(wk,wkout,info)
-    use psb_base_mod
-    Implicit None
-
-    ! Arguments
-    class(amg_smlprec_wrk_type), target, intent(inout) :: wk
-    class(amg_smlprec_wrk_type), target, intent(inout) :: wkout
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-    info = psb_success_
-
-    call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
-    call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
-    call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
-    call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
-    call wk%vtx%clone(wkout%vtx,info)
-    call wk%vty%clone(wkout%vty,info)
-    call wk%vx2l%clone(wkout%vx2l,info)
-    call wk%vy2l%clone(wkout%vy2l,info)
-    if (allocated(wkout%wv)) then
-      do i=1,size(wkout%wv)
-        call wkout%wv(i)%free(info)
-      end do
-      deallocate( wkout%wv)
-    end if
-    allocate(wkout%wv(size(wk%wv)),stat=info)
-    do i=1,size(wk%wv)
-      call wk%wv(i)%clone(wkout%wv(i),info)
-    end do
-    return
-
-  end subroutine s_wrk_clone
-
-  subroutine s_wrk_move_alloc(wk, b,info)
-    implicit none
-    class(amg_smlprec_wrk_type), target, intent(inout) :: wk, b
-    integer(psb_ipk_), intent(out) :: info
-
-    call b%free(info)
-    call move_alloc(wk%tx,b%tx)
-    call move_alloc(wk%ty,b%ty)
-    call move_alloc(wk%x2l,b%x2l)
-    call move_alloc(wk%y2l,b%y2l)
-    !
-    ! Should define V%move_alloc....
-    call move_alloc(wk%vtx%v,b%vtx%v)
-    call move_alloc(wk%vty%v,b%vty%v)
-    call move_alloc(wk%vx2l%v,b%vx2l%v)
-    call move_alloc(wk%vy2l%v,b%vy2l%v)
-    call move_alloc(wk%wv,b%wv)
-
-  end subroutine s_wrk_move_alloc
-
-  subroutine s_wrk_cnv(wk,info,vmold)
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(amg_smlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(out)                    :: info
-    class(psb_s_base_vect_type), intent(in), optional  :: vmold
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-    if (present(vmold)) then
-      call wk%vtx%cnv(vmold)
-      call wk%vty%cnv(vmold)
-      call wk%vx2l%cnv(vmold)
-      call wk%vy2l%cnv(vmold)
-      if (allocated(wk%wv)) then
-        do i=1,size(wk%wv)
-          call wk%wv(i)%cnv(vmold)
-        end do
-      end if
-    end if
-  end subroutine s_wrk_cnv
-
-  function s_wrk_sizeof(wk) result(val)
-    use psb_realloc_mod
-    implicit none
-    class(amg_smlprec_wrk_type), intent(in) :: wk
-    integer(psb_epk_) :: val
-    integer :: i
-    val = 0
-    val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%tx)
-    val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%ty)
-    val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%x2l)
-    val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%y2l)
-    val = val + wk%vtx%sizeof()
-    val = val + wk%vty%sizeof()
-    val = val + wk%vx2l%sizeof()
-    val = val + wk%vy2l%sizeof()
-    if (allocated(wk%wv)) then
-      do i=1, size(wk%wv)
-        val = val + wk%wv(i)%sizeof()
-      end do
-    end if
-  end function s_wrk_sizeof
-
-  subroutine s_remap_data_clone(rmp, remap_out, info)
-    use psb_base_mod
-    implicit none
-    ! Arguments
-    class(amg_s_remap_data_type), target, intent(inout) :: rmp
-    class(amg_s_remap_data_type), target, intent(inout) :: remap_out
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-
-    call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
-    if (info == psb_success_) &
-         & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
-    remap_out%idest = rmp%idest
-    call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
-    call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
-  end subroutine s_remap_data_clone
-
+  
 end module amg_s_onelev_mod

amgprec/amg_s_parmatch_aggregator_mod.F90

@@ -136,7 +136,7 @@ module amg_s_parmatch_aggregator_mod
     procedure, pass(ag) :: mat_bld      => amg_s_parmatch_aggregator_mat_bld
     procedure, pass(ag) :: mat_asb      => amg_s_parmatch_aggregator_mat_asb
     procedure, pass(ag) :: inner_mat_asb      => amg_s_parmatch_aggregator_inner_mat_asb
-    procedure, pass(ag) :: bld_map      => amg_s_parmatch_aggregator_bld_map
+    procedure, pass(ag) :: bld_linmap   => amg_s_parmatch_aggregator_bld_linmap
     procedure, pass(ag) :: csetc        => amg_s_parmatch_aggr_csetc
     procedure, pass(ag) :: cseti        => amg_s_parmatch_aggr_cseti
     procedure, pass(ag) :: default      => amg_s_parmatch_aggr_set_default
@@ -643,7 +643,7 @@ contains
     end select
   end subroutine amg_s_parmatch_aggregator_clone
 
-  subroutine  amg_s_parmatch_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_s_parmatch_aggregator_bld_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
        & op_restr,op_prol,map,info)
     use psb_base_mod
     implicit none
@@ -654,7 +654,7 @@ contains
     type(psb_slinmap_type), intent(out)     :: map
     integer(psb_ipk_), intent(out)          :: info
     integer(psb_ipk_) :: err_act
-    character(len=20) :: name='s_parmatch_aggregator_bld_map'
+    character(len=20) :: name='s_parmatch_aggregator_bld_linmap'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -680,5 +680,5 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_s_parmatch_aggregator_bld_map
+  end subroutine amg_s_parmatch_aggregator_bld_linmap
 end module amg_s_parmatch_aggregator_mod

amgprec/amg_s_prec_type.f90

@@ -102,6 +102,7 @@ module amg_s_prec_type
     ! The multilevel hierarchy
     !
     type(amg_s_onelev_type), allocatable :: precv(:)
+    integer(psb_ipk_)                    :: nlevs
   contains
     procedure, pass(prec)               :: psb_s_apply2_vect => amg_s_apply2_vect
     procedure, pass(prec)               :: psb_s_apply1_vect => amg_s_apply1_vect
@@ -119,6 +120,7 @@ module amg_s_prec_type
     procedure, pass(prec)               :: cmp_complexity => amg_s_cmp_compl
     procedure, pass(prec)               :: get_avg_cr => amg_s_get_avg_cr
     procedure, pass(prec)               :: cmp_avg_cr => amg_s_cmp_avg_cr
+    procedure, pass(prec)               :: set_nlevs  => amg_s_set_nlevs
     procedure, pass(prec)               :: get_nlevs  => amg_s_get_nlevs
     procedure, pass(prec)               :: get_nzeros => amg_s_get_nzeros
     procedure, pass(prec)               :: sizeof => amg_sprec_sizeof
@@ -435,10 +437,19 @@ contains
     class(amg_sprec_type), intent(in) :: prec
     integer(psb_ipk_) :: val
     val = 0
-    if (allocated(prec%precv)) then
-      val = size(prec%precv)
-    end if
+!!$    if (allocated(prec%precv)) then
+!!$      val = size(prec%precv)
+!!$    end if
+    val = prec%nlevs
+!!$    write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv)
   end function amg_s_get_nlevs
+
+  subroutine amg_s_set_nlevs(prec,nl) 
+    implicit none
+    class(amg_sprec_type), intent(inout) :: prec
+    integer(psb_ipk_) :: nl
+    prec%nlevs = nl
+  end subroutine amg_s_set_nlevs
   !
   ! Function returning the size of the amg_prec_type data structure
   ! in bytes or in number of nonzeros of the operator(s) involved.
@@ -509,7 +520,7 @@ contains
 
     real(psb_spk_) :: num, den, nmin
     type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: il
+    integer(psb_ipk_)   :: il,nl
 
     num = -sone
     den = sone
@@ -519,7 +530,10 @@ contains
       num = prec%precv(il)%base_a%get_nzeros()
       if (num >= szero) then
         den = num
-        do il=2,size(prec%precv)
+        nl = prec%get_nlevs()
+!!$        write(0,*) 'Inside cmp_compl ',nl,size(prec%precv)
+        do il=2, nl
+!!$          write(0,*) '                 ',il,associated(prec%precv(il)%base_a)
           num = num + max(0,prec%precv(il)%base_a%get_nzeros())
         end do
       end if
@@ -550,7 +564,6 @@ contains
   end function amg_s_get_avg_cr
 
   subroutine amg_s_cmp_avg_cr(prec)
-
     implicit none
     class(amg_sprec_type), intent(inout) :: prec
 
@@ -558,17 +571,18 @@ contains
     type(psb_ctxt_type) :: ctxt
     integer(psb_ipk_)   :: il, nl, iam, np
 
-
     avgcr = szero
+    nl = prec%get_nlevs()
+    do il=2,nl
+      if (prec%precv(il)%base_desc%is_ok()) then 
+        ctxt = prec%precv(il)%base_desc%get_ctxt()
+        call psb_info(ctxt,iam,np)
+        if (iam >=0)  avgcr = avgcr + max(szero,prec%precv(il)%szratio)
+      end if
+    end do
+    avgcr = avgcr / (nl-1)
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    if (allocated(prec%precv)) then
-      nl = size(prec%precv)
-      do il=2,nl
-        avgcr = avgcr + max(szero,prec%precv(il)%szratio)
-      end do
-      avgcr = avgcr / (nl-1)
-    end if
     call psb_sum(ctxt,avgcr)
     prec%ag_data%avg_cr = avgcr/np
   end subroutine amg_s_cmp_avg_cr
@@ -586,9 +600,7 @@ contains
   !             error code.
   !
   subroutine amg_sprecfree(p,info)
-
     implicit none
-
     ! Arguments
     type(amg_sprec_type), intent(inout) :: p
     integer(psb_ipk_), intent(out)        :: info
@@ -614,9 +626,7 @@ contains
   end subroutine amg_sprecfree
 
   subroutine amg_s_prec_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_sprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -653,9 +663,7 @@ contains
   end subroutine amg_s_prec_free
 
   subroutine amg_s_smoothers_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_sprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -672,7 +680,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      do i=1,size(prec%precv)
+      do i=1,prec%get_nlevs()
         call prec%precv(i)%free_smoothers(info)
       end do
     end if
@@ -686,9 +694,7 @@ contains
   end subroutine amg_s_smoothers_free
 
   subroutine amg_s_hierarchy_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_sprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -715,7 +721,6 @@ contains
 
   end subroutine amg_s_hierarchy_free
 
-
   !
   ! Top level methods.
   !
@@ -780,7 +785,6 @@ contains
 
   end subroutine amg_s_apply1_vect
 
-
   subroutine amg_s_apply2v(prec,x,y,desc_data,info,trans,work)
     implicit none
     type(psb_desc_type),intent(in)    :: desc_data
@@ -845,7 +849,6 @@ contains
   subroutine amg_s_dump(prec,info,istart,iend,iproc,prefix,head,&
        & ac,rp,smoother,solver,tprol,&
        & global_num)
-
     implicit none
     class(amg_sprec_type), intent(in)     :: prec
     integer(psb_ipk_), intent(out)          :: info
@@ -862,7 +865,7 @@ contains
     info = 0
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    iln = size(prec%precv)
+    iln = prec%get_nlevs()
     if (present(istart)) then
       il1 = max(1,istart)
     else
@@ -886,7 +889,6 @@ contains
   end subroutine amg_s_dump
 
   subroutine amg_s_cnv(prec,info,amold,vmold,imold)
-
     implicit none
     class(amg_sprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)       :: info
@@ -898,7 +900,7 @@ contains
 
     info = psb_success_
     if (allocated(prec%precv)) then
-      do i=1,size(prec%precv)
+      do i=1,prec%get_nlevs()
         if (info == psb_success_ ) &
              & call prec%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
       end do
@@ -907,7 +909,6 @@ contains
   end subroutine amg_s_cnv
 
   subroutine amg_s_clone(prec,precout,info)
-
     implicit none
     class(amg_sprec_type), intent(inout) :: prec
     class(psb_sprec_type), intent(inout) :: precout
@@ -919,7 +920,6 @@ contains
   end subroutine amg_s_clone
 
   subroutine amg_s_inner_clone(prec,precout,info)
-
     implicit none
     class(amg_sprec_type), intent(inout)         :: prec
     class(psb_sprec_type), target, intent(inout) :: precout
@@ -935,8 +935,9 @@ contains
       pout%ctxt          = prec%ctxt
       pout%ag_data       = prec%ag_data
       pout%outer_sweeps  = prec%outer_sweeps
+      pout%nlevs         = prec%nlevs
       if (allocated(prec%precv)) then
-        ln = size(prec%precv)
+        ln = prec%get_nlevs()
         allocate(pout%precv(ln),stat=info)
         if (info /= psb_success_) goto 9999
         if (ln >= 1) then
@@ -944,6 +945,7 @@ contains
         end if
         do lev=2, ln
           if (info /= psb_success_) exit
+!!$          write(0,*) 'Inner_clone must be checked and reimplemented! '
           call prec%precv(lev)%clone(pout%precv(lev),info)
           if (info == psb_success_) then
             pout%precv(lev)%base_a       => pout%precv(lev)%ac
@@ -1023,7 +1025,7 @@ contains
     if (psb_errstatus_fatal()) then
       info = psb_err_internal_error_; goto 9999
     end if
-    nlev   = size(prec%precv)
+    nlev   = prec%get_nlevs()
     level = 1
     do level = 1, nlev
       call prec%precv(level)%allocate_wrk(info,vmold=vmold)
@@ -1046,7 +1048,6 @@ contains
   subroutine amg_s_free_wrk(prec,info)
     use psb_base_mod
     implicit none
-
     ! Arguments
     class(amg_sprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -1063,7 +1064,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      nlev   = size(prec%precv)
+      nlev   = prec%get_nlevs()
       do level = 1, nlev
         call prec%precv(level)%free_wrk(info)
       end do

amgprec/amg_z_base_aggregator_mod.f90

@@ -89,7 +89,7 @@ module amg_z_base_aggregator_mod
     procedure, pass(ag) :: bld_tprol   => amg_z_base_aggregator_build_tprol
     procedure, pass(ag) :: mat_bld     => amg_z_base_aggregator_mat_bld
     procedure, pass(ag) :: mat_asb     => amg_z_base_aggregator_mat_asb
-    procedure, pass(ag) :: bld_map     => amg_z_base_aggregator_bld_map
+    procedure, pass(ag) :: bld_linmap  => amg_z_base_aggregator_bld_linmap
     procedure, pass(ag) :: update_next => amg_z_base_aggregator_update_next
     procedure, pass(ag) :: clone       => amg_z_base_aggregator_clone
     procedure, pass(ag) :: free        => amg_z_base_aggregator_free
@@ -458,7 +458,7 @@ contains
   end subroutine amg_z_base_aggregator_mat_asb
 
   !
-  !> Function   bld_map
+  !> Function   bld_linmap
   !! \memberof  amg_z_base_aggregator_type
   !! \brief     Build linear map between hierarchy levels 
   !!
@@ -473,7 +473,7 @@ contains
   !!  \param map       The output map
   !!  \param info    Return code
   !!  
-  subroutine  amg_z_base_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_z_base_aggregator_bld_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
        & op_restr,op_prol,map,info)
     use psb_base_mod
     implicit none
@@ -484,7 +484,7 @@ contains
     type(psb_zlinmap_type), intent(out)    :: map
     integer(psb_ipk_), intent(out)       :: info
     integer(psb_ipk_) :: err_act
-    character(len=20) :: name='z_base_aggregator_bld_map'
+    character(len=20) :: name='z_base_aggregator_bld_linmap'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -508,7 +508,6 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_z_base_aggregator_bld_map
-
+  end subroutine amg_z_base_aggregator_bld_linmap
 
 end module amg_z_base_aggregator_mod

amgprec/amg_z_inner_mod.f90

@@ -67,7 +67,7 @@ module amg_z_inner_mod
   end interface amg_mlprec_bld
 
   interface amg_mlprec_aply
-    subroutine amg_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
+    subroutine amg_zmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info)
       import :: psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_
       import :: amg_zprec_type
       implicit none 
@@ -79,7 +79,7 @@ module amg_z_inner_mod
       character,intent(in)               :: trans
       complex(psb_dpk_),target             :: work(:)
       integer(psb_ipk_), intent(out)     :: info
-    end subroutine amg_zmlprec_aply
+    end subroutine amg_zmlprec_aply_a
     subroutine amg_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
       import :: psb_zspmat_type, psb_desc_type, &
            & psb_dpk_, psb_z_vect_type, psb_ipk_

amgprec/amg_z_onelev_mod.f90

@@ -154,13 +154,35 @@ module amg_z_onelev_mod
   private :: z_wrk_alloc, z_wrk_free, &
        & z_wrk_clone, z_wrk_move_alloc, z_wrk_cnv, z_wrk_sizeof
 
+  !
+  ! Remap.
+  !  This keeps track of remapping.
+  !  Logic here is as follows:
+  !  1. AC_PRE_REMAP  need to figure out if we
+  !                really need it.
+  !  2. DESC_AC_PRE_REMAP  contains the descriptor before
+  !                remapping. Meaning that it is possible
+  !                to implement the RESTRICTOR operator by
+  !                 a. Doing LINMAP_U2V onto this one
+  !                 b. For each process, send the data to
+  !                    IDEST.
+  !                This assumes that remapping goes by
+  !                a factor of 2.
+  !                For the PROLONGATOR operators, we first
+  !                use DESC_AC, then split and send onto
+  !                the processes in DESC_AC_PRE_REMAP.
+  !
+  ! To be fixed: what happens if NP the starting processes
+  ! is not an even number? Coordinate with _X_remap in PSBLAS
+  ! 
   type amg_z_remap_data_type
     type(psb_zspmat_type)          :: ac_pre_remap
     type(psb_desc_type)            :: desc_ac_pre_remap
     integer(psb_ipk_)              :: idest
     integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
   contains
-    procedure, pass(rmp) :: clone   => z_remap_data_clone
+    procedure, pass(rmp) :: clone      => z_remap_data_clone
+    procedure, pass(rmp) :: move_alloc => z_remap_move_alloc
   end type amg_z_remap_data_type
 
   type amg_z_onelev_type
@@ -206,7 +228,7 @@ module amg_z_onelev_mod
     procedure, pass(lv) :: get_wrksz => z_base_onelev_get_wrksize
     procedure, pass(lv) :: allocate_wrk   => z_base_onelev_allocate_wrk
     procedure, pass(lv) :: free_wrk       => z_base_onelev_free_wrk
-    procedure, nopass   :: stringval => amg_stringval
+    procedure, nopass   :: stringval  => amg_stringval
     procedure, pass(lv) :: move_alloc => z_base_onelev_move_alloc
 
 
@@ -230,9 +252,7 @@ module amg_z_onelev_mod
        & z_base_onelev_free_wrk
 
   interface
-    subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
-      import :: psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_lzspmat_type, psb_lpk_
-      import :: amg_z_onelev_type
+    module subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
       implicit none
       class(amg_z_onelev_type), intent(inout), target :: lv
       type(psb_zspmat_type), intent(in) :: a
@@ -244,10 +264,7 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv)
-      import :: psb_z_base_sparse_mat, psb_z_base_vect_type, &
-           & psb_i_base_vect_type, psb_dpk_, amg_z_onelev_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv)
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       integer(psb_ipk_), intent(out) :: info
@@ -259,10 +276,7 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
-      import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
-           & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
       Implicit None
       ! Arguments
       class(amg_z_onelev_type), intent(in)    :: lv
@@ -275,10 +289,8 @@ module amg_z_onelev_mod
   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
+    module subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,&
+         & iout,verbosity, prefix,global) 
       Implicit None
       ! Arguments
       class(amg_z_onelev_type), intent(in)    :: lv
@@ -292,10 +304,7 @@ module amg_z_onelev_mod
   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_, &
-           & psb_z_base_sparse_mat, psb_ipk_, psb_i_base_vect_type
-      ! Arguments
+    module subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
       class(amg_z_onelev_type), intent(inout)            :: lv
       integer(psb_ipk_), intent(out)                     :: info
       class(psb_z_base_sparse_mat), intent(in), optional :: amold
@@ -305,48 +314,32 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_free(lv,info)
-      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
+    module subroutine amg_z_base_onelev_free(lv,info)
       implicit none
-
       class(amg_z_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)                :: info
     end subroutine amg_z_base_onelev_free
   end interface
 
   interface
-    subroutine amg_z_base_onelev_free_smoothers(lv,info)
-      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
+    module subroutine amg_z_base_onelev_free_smoothers(lv,info)
       implicit none
-
       class(amg_z_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)                :: info
     end subroutine amg_z_base_onelev_free_smoothers
   end interface
 
   interface
-    subroutine amg_z_base_onelev_check(lv,info)
-      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
+    module subroutine amg_z_base_onelev_check(lv,info)
       Implicit None
-      ! Arguments
       class(amg_z_onelev_type), intent(inout) :: lv
       integer(psb_ipk_), intent(out)            :: info
     end subroutine amg_z_base_onelev_check
   end interface
 
   interface
-    subroutine amg_z_base_onelev_setsm(lv,val,info,pos)
-      import :: psb_dpk_, amg_z_onelev_type, amg_z_base_smoother_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_z_base_onelev_setsm(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_z_onelev_type), target, intent(inout) :: lv
       class(amg_z_base_smoother_type), intent(in)     :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -355,12 +348,8 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_setsv(lv,val,info,pos)
-      import :: psb_dpk_, amg_z_onelev_type, amg_z_base_solver_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_z_base_onelev_setsv(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_z_onelev_type), target, intent(inout) :: lv
       class(amg_z_base_solver_type), intent(in)       :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -369,12 +358,8 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_setag(lv,val,info,pos)
-      import :: psb_dpk_, amg_z_onelev_type, amg_z_base_aggregator_type, &
-           & psb_ipk_, psb_epk_, psb_desc_type
+    module subroutine amg_z_base_onelev_setag(lv,val,info,pos)
       Implicit None
-
-      ! Arguments
       class(amg_z_onelev_type), target, intent(inout) :: lv
       class(amg_z_base_aggregator_type), intent(in)       :: val
       integer(psb_ipk_), intent(out)                  :: info
@@ -383,13 +368,8 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx)
       Implicit None
-
-      ! Arguments
       class(amg_z_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       integer(psb_ipk_), intent(in)             :: val
@@ -400,12 +380,8 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
       Implicit None
-      ! Arguments
       class(amg_z_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       character(len=*), intent(in)              :: val
@@ -416,12 +392,8 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx)
-      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
+    module subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx)
       Implicit None
-
       class(amg_z_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       real(psb_dpk_), intent(in)                 :: val
@@ -432,11 +404,8 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
+    module subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
          & solver,tprol,global_num)
-      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
       class(amg_z_onelev_type), intent(in) :: lv
       integer(psb_ipk_), intent(in)          :: level
@@ -447,8 +416,7 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
-      import
+    module subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       complex(psb_dpk_), intent(in)     :: alpha, beta
@@ -457,8 +425,8 @@ module amg_z_onelev_mod
       integer(psb_ipk_), intent(out) :: info
       complex(psb_dpk_), optional       :: work(:)
     end subroutine amg_z_base_onelev_map_rstr_a
-    subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
-      import
+    module subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
+         & work,vtx,vty)
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       complex(psb_dpk_), intent(in)           :: alpha, beta
@@ -470,8 +438,7 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
-      import
+    module subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       complex(psb_dpk_), intent(in)     :: alpha, beta
@@ -481,8 +448,8 @@ module amg_z_onelev_mod
       complex(psb_dpk_), optional          :: work(:)
 
     end subroutine amg_z_base_onelev_map_prol_a
-    subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
-      import
+    module subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
+         & work,vtx,vty)
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       complex(psb_dpk_), intent(in)           :: alpha, beta
@@ -493,6 +460,118 @@ module amg_z_onelev_mod
     end subroutine amg_z_base_onelev_map_prol_v
   end interface
 
+  interface 
+    module subroutine z_base_onelev_move_alloc(lv, b,info)
+      implicit none
+      class(amg_z_onelev_type), target, intent(inout) :: lv, b
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine z_base_onelev_move_alloc
+  end interface
+
+  interface 
+    module subroutine z_base_onelev_allocate_wrk(lv,info,vmold)
+      implicit none
+      class(amg_z_onelev_type), target, intent(inout) :: lv
+      integer(psb_ipk_), intent(out) :: info
+      class(psb_z_base_vect_type), intent(in), optional  :: vmold
+    end subroutine z_base_onelev_allocate_wrk
+  end interface
+  
+  interface 
+    module subroutine z_base_onelev_free_wrk(lv,info)
+      implicit none
+      class(amg_z_onelev_type), target, intent(inout) :: lv
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine z_base_onelev_free_wrk
+  end interface
+
+  interface 
+    module  subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
+      Implicit None
+      ! Arguments
+      class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(in)                     :: nwv
+      type(psb_desc_type), intent(in)                   :: desc
+      integer(psb_ipk_), intent(out)                    :: info
+      class(psb_z_base_vect_type), intent(in), optional  :: vmold
+      type(psb_desc_type), intent(in), optional          :: desc2
+    end subroutine z_wrk_alloc
+  end interface
+
+  interface 
+    module subroutine z_inner_do_wrk_alloc(wk,nwv,desc,vmold)
+      class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(in)                     :: nwv
+      type(psb_desc_type), intent(in)                   :: desc
+      class(psb_z_base_vect_type), intent(in), optional  :: vmold
+    end subroutine z_inner_do_wrk_alloc
+  end interface
+
+  interface 
+    module  subroutine z_wrk_free(wk,info)
+      Implicit None
+      ! Arguments
+      class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine z_wrk_free
+  end interface
+
+  interface 
+    module  subroutine z_wrk_clone(wk,wkout,info)
+      Implicit None
+      ! Arguments
+      class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
+      class(amg_zmlprec_wrk_type), target, intent(inout) :: wkout
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine z_wrk_clone
+  end interface
+
+  interface 
+    module subroutine z_wrk_move_alloc(wk, b,info)
+      implicit none
+      class(amg_zmlprec_wrk_type), target, intent(inout) :: wk, b
+      integer(psb_ipk_), intent(out) :: info
+    end subroutine z_wrk_move_alloc
+  end interface
+
+  interface
+    module subroutine z_wrk_cnv(wk,info,vmold)
+      Implicit None
+      class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
+      integer(psb_ipk_), intent(out)                    :: info
+      class(psb_z_base_vect_type), intent(in), optional  :: vmold
+    end subroutine z_wrk_cnv
+  end interface
+
+  interface
+    module function z_wrk_sizeof(wk) result(val)
+      implicit none
+      class(amg_zmlprec_wrk_type), intent(in) :: wk
+      integer(psb_epk_) :: val
+    end  function z_wrk_sizeof
+  end interface
+
+  interface 
+    module subroutine z_remap_data_clone(rmp, remap_out, info)
+      implicit none
+      ! Arguments
+      class(amg_z_remap_data_type), target, intent(inout) :: rmp
+      class(amg_z_remap_data_type), target, intent(inout) :: remap_out
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine z_remap_data_clone
+  end interface
+
+  interface 
+    module subroutine z_remap_move_alloc(rmp, remap_out, info)
+      implicit none
+      ! Arguments
+      class(amg_z_remap_data_type), target, intent(inout) :: rmp
+      class(amg_z_remap_data_type), target, intent(inout) :: remap_out
+      integer(psb_ipk_), intent(out)                    :: info
+    end subroutine z_remap_move_alloc
+  end interface
+  
+
 contains
   !
   ! Function returning the size of the amg_prec_type data structure
@@ -618,7 +697,7 @@ contains
     ! Arguments
     class(amg_z_onelev_type), target, intent(inout) :: lv
     class(amg_z_onelev_type), target, intent(inout) :: lvout
-    integer(psb_ipk_), intent(out)                    :: info
+    integer(psb_ipk_), intent(out)                  :: info
 
     info = psb_success_
     if (allocated(lv%sm)) then
@@ -660,36 +739,6 @@ contains
 
   end subroutine z_base_onelev_clone
 
-  subroutine z_base_onelev_move_alloc(lv, b,info)
-    use psb_base_mod
-    implicit none
-    class(amg_z_onelev_type), target, intent(inout) :: lv, b
-    integer(psb_ipk_), intent(out) :: info
-
-    call b%free(info)
-    b%parms  = lv%parms
-    b%szratio = lv%szratio
-    if (associated(lv%sm2,lv%sm2a)) then
-      call move_alloc(lv%sm,b%sm)
-      call move_alloc(lv%sm2a,b%sm2a)
-      b%sm2 =>b%sm2a
-    else
-      call move_alloc(lv%sm,b%sm)
-      call move_alloc(lv%sm2a,b%sm2a)
-      b%sm2 =>b%sm
-    end if
-
-    call move_alloc(lv%aggr,b%aggr)
-    if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
-    if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
-    if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
-    if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
-    b%base_a    => lv%base_a
-    b%base_desc => lv%base_desc
-
-  end subroutine z_base_onelev_move_alloc
-
-
   function z_base_onelev_get_wrksize(lv) result(val)
     implicit none
     class(amg_z_onelev_type), intent(inout) :: lv
@@ -727,269 +776,5 @@ contains
 
   end function z_base_onelev_get_wrksize
 
-  subroutine z_base_onelev_allocate_wrk(lv,info,vmold)
-    use psb_base_mod
-    implicit none
-    class(amg_z_onelev_type), target, intent(inout) :: lv
-    integer(psb_ipk_), intent(out) :: info
-    class(psb_z_base_vect_type), intent(in), optional  :: vmold
-    !
-    integer(psb_ipk_) :: nwv, i
-    info = psb_success_
-    nwv = lv%get_wrksz()
-    if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
-    if (info == 0) then
-      if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
-        !
-        !  Need to fix this, we need two different allocations
-        !
-        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
-             & desc2=lv%remap_data%desc_ac_pre_remap)
-      else
-        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
-      end if
-    end if
-
-  end subroutine z_base_onelev_allocate_wrk
-
-
-  subroutine z_base_onelev_free_wrk(lv,info)
-    use psb_base_mod
-    implicit none
-    class(amg_z_onelev_type), target, intent(inout) :: lv
-    integer(psb_ipk_), intent(out) :: info
-    !
-    integer(psb_ipk_) :: nwv,i
-    info = psb_success_
-
-    if (allocated(lv%wrk)) then
-      call lv%wrk%free(info)
-      if (info == 0) deallocate(lv%wrk,stat=info)
-    end if
-  end subroutine z_base_onelev_free_wrk
-
-  subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(in)                     :: nwv
-    type(psb_desc_type), intent(in)                   :: desc
-    integer(psb_ipk_), intent(out)                    :: info
-    class(psb_z_base_vect_type), intent(in), optional  :: vmold
-    type(psb_desc_type), intent(in), optional          :: desc2
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-    call wk%free(info)
-    if  (present(desc2)) then
-!!$      write(0,*) 'Check on wrk_alloc 2',&
-!!$           & desc2%get_local_rows(), desc%get_local_rows(),&
-!!$           & desc2%get_local_cols(),desc%get_local_cols()
-!!$      flush(0)
-      if (desc2%get_local_cols()>desc%get_local_cols()) then
-        call psb_geasb(wk%vx2l,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vy2l,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vtx,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vty,desc2,info,&
-             & scratch=.true.,mold=vmold)
-        allocate(wk%wv(nwv),stat=info)
-        do i=1,nwv
-          call psb_geasb(wk%wv(i),desc2,info,&
-               & scratch=.true.,mold=vmold)
-        end do
-      else
-!!$        write(0,*) 'Check on wrk_alloc 1.5 ',&
-!!$             & desc%get_local_rows(),&
-!!$             & desc%get_local_cols()
-        call psb_geasb(wk%vx2l,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vy2l,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vtx,desc,info,&
-             & scratch=.true.,mold=vmold)
-        call psb_geasb(wk%vty,desc,info,&
-             & scratch=.true.,mold=vmold)
-        allocate(wk%wv(nwv),stat=info)
-        do i=1,nwv
-          call psb_geasb(wk%wv(i),desc,info,&
-               & scratch=.true.,mold=vmold)
-        end do
-      end if
-    else
-!!$      write(0,*) 'Check on wrk_alloc 1 ',&
-!!$           & desc%get_local_rows(),&
-!!$           & desc%get_local_cols()
-      call psb_geasb(wk%vx2l,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vy2l,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vtx,desc,info,&
-           & scratch=.true.,mold=vmold)
-      call psb_geasb(wk%vty,desc,info,&
-           & scratch=.true.,mold=vmold)
-      allocate(wk%wv(nwv),stat=info)
-      do i=1,nwv
-        call psb_geasb(wk%wv(i),desc,info,&
-             & scratch=.true.,mold=vmold)
-      end do
-    end if
-  end subroutine z_wrk_alloc
-
-  subroutine z_wrk_free(wk,info)
-
-    Implicit None
-
-    ! Arguments
-    class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-    info = psb_success_
-
-    if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
-    if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
-    if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
-    if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
-    call wk%vtx%free(info)
-    call wk%vty%free(info)
-    call wk%vx2l%free(info)
-    call wk%vy2l%free(info)
-    if (allocated(wk%wv)) then
-      do i=1,size(wk%wv)
-        call wk%wv(i)%free(info)
-      end do
-      deallocate(wk%wv, stat=info)
-    end if
-
-  end subroutine z_wrk_free
-
-  subroutine z_wrk_clone(wk,wkout,info)
-    use psb_base_mod
-    Implicit None
-
-    ! Arguments
-    class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
-    class(amg_zmlprec_wrk_type), target, intent(inout) :: wkout
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-    info = psb_success_
-
-    call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
-    call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
-    call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
-    call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
-    call wk%vtx%clone(wkout%vtx,info)
-    call wk%vty%clone(wkout%vty,info)
-    call wk%vx2l%clone(wkout%vx2l,info)
-    call wk%vy2l%clone(wkout%vy2l,info)
-    if (allocated(wkout%wv)) then
-      do i=1,size(wkout%wv)
-        call wkout%wv(i)%free(info)
-      end do
-      deallocate( wkout%wv)
-    end if
-    allocate(wkout%wv(size(wk%wv)),stat=info)
-    do i=1,size(wk%wv)
-      call wk%wv(i)%clone(wkout%wv(i),info)
-    end do
-    return
-
-  end subroutine z_wrk_clone
-
-  subroutine z_wrk_move_alloc(wk, b,info)
-    implicit none
-    class(amg_zmlprec_wrk_type), target, intent(inout) :: wk, b
-    integer(psb_ipk_), intent(out) :: info
-
-    call b%free(info)
-    call move_alloc(wk%tx,b%tx)
-    call move_alloc(wk%ty,b%ty)
-    call move_alloc(wk%x2l,b%x2l)
-    call move_alloc(wk%y2l,b%y2l)
-    !
-    ! Should define V%move_alloc....
-    call move_alloc(wk%vtx%v,b%vtx%v)
-    call move_alloc(wk%vty%v,b%vty%v)
-    call move_alloc(wk%vx2l%v,b%vx2l%v)
-    call move_alloc(wk%vy2l%v,b%vy2l%v)
-    call move_alloc(wk%wv,b%wv)
-
-  end subroutine z_wrk_move_alloc
-
-  subroutine z_wrk_cnv(wk,info,vmold)
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
-    integer(psb_ipk_), intent(out)                    :: info
-    class(psb_z_base_vect_type), intent(in), optional  :: vmold
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-    if (present(vmold)) then
-      call wk%vtx%cnv(vmold)
-      call wk%vty%cnv(vmold)
-      call wk%vx2l%cnv(vmold)
-      call wk%vy2l%cnv(vmold)
-      if (allocated(wk%wv)) then
-        do i=1,size(wk%wv)
-          call wk%wv(i)%cnv(vmold)
-        end do
-      end if
-    end if
-  end subroutine z_wrk_cnv
-
-  function z_wrk_sizeof(wk) result(val)
-    use psb_realloc_mod
-    implicit none
-    class(amg_zmlprec_wrk_type), intent(in) :: wk
-    integer(psb_epk_) :: val
-    integer :: i
-    val = 0
-    val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%tx)
-    val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%ty)
-    val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%x2l)
-    val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%y2l)
-    val = val + wk%vtx%sizeof()
-    val = val + wk%vty%sizeof()
-    val = val + wk%vx2l%sizeof()
-    val = val + wk%vy2l%sizeof()
-    if (allocated(wk%wv)) then
-      do i=1, size(wk%wv)
-        val = val + wk%wv(i)%sizeof()
-      end do
-    end if
-  end function z_wrk_sizeof
-
-  subroutine z_remap_data_clone(rmp, remap_out, info)
-    use psb_base_mod
-    implicit none
-    ! Arguments
-    class(amg_z_remap_data_type), target, intent(inout) :: rmp
-    class(amg_z_remap_data_type), target, intent(inout) :: remap_out
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-
-    call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
-    if (info == psb_success_) &
-         & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
-    remap_out%idest = rmp%idest
-    call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
-    call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
-  end subroutine z_remap_data_clone
-
+  
 end module amg_z_onelev_mod

amgprec/amg_z_prec_type.f90

@@ -102,6 +102,7 @@ module amg_z_prec_type
     ! The multilevel hierarchy
     !
     type(amg_z_onelev_type), allocatable :: precv(:)
+    integer(psb_ipk_)                    :: nlevs
   contains
     procedure, pass(prec)               :: psb_z_apply2_vect => amg_z_apply2_vect
     procedure, pass(prec)               :: psb_z_apply1_vect => amg_z_apply1_vect
@@ -119,6 +120,7 @@ module amg_z_prec_type
     procedure, pass(prec)               :: cmp_complexity => amg_z_cmp_compl
     procedure, pass(prec)               :: get_avg_cr => amg_z_get_avg_cr
     procedure, pass(prec)               :: cmp_avg_cr => amg_z_cmp_avg_cr
+    procedure, pass(prec)               :: set_nlevs  => amg_z_set_nlevs
     procedure, pass(prec)               :: get_nlevs  => amg_z_get_nlevs
     procedure, pass(prec)               :: get_nzeros => amg_z_get_nzeros
     procedure, pass(prec)               :: sizeof => amg_zprec_sizeof
@@ -435,10 +437,19 @@ contains
     class(amg_zprec_type), intent(in) :: prec
     integer(psb_ipk_) :: val
     val = 0
-    if (allocated(prec%precv)) then
-      val = size(prec%precv)
-    end if
+!!$    if (allocated(prec%precv)) then
+!!$      val = size(prec%precv)
+!!$    end if
+    val = prec%nlevs
+!!$    write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv)
   end function amg_z_get_nlevs
+
+  subroutine amg_z_set_nlevs(prec,nl) 
+    implicit none
+    class(amg_zprec_type), intent(inout) :: prec
+    integer(psb_ipk_) :: nl
+    prec%nlevs = nl
+  end subroutine amg_z_set_nlevs
   !
   ! Function returning the size of the amg_prec_type data structure
   ! in bytes or in number of nonzeros of the operator(s) involved.
@@ -509,7 +520,7 @@ contains
 
     real(psb_dpk_) :: num, den, nmin
     type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: il
+    integer(psb_ipk_)   :: il,nl
 
     num = -done
     den = done
@@ -519,7 +530,10 @@ contains
       num = prec%precv(il)%base_a%get_nzeros()
       if (num >= dzero) then
         den = num
-        do il=2,size(prec%precv)
+        nl = prec%get_nlevs()
+!!$        write(0,*) 'Inside cmp_compl ',nl,size(prec%precv)
+        do il=2, nl
+!!$          write(0,*) '                 ',il,associated(prec%precv(il)%base_a)
           num = num + max(0,prec%precv(il)%base_a%get_nzeros())
         end do
       end if
@@ -550,7 +564,6 @@ contains
   end function amg_z_get_avg_cr
 
   subroutine amg_z_cmp_avg_cr(prec)
-
     implicit none
     class(amg_zprec_type), intent(inout) :: prec
 
@@ -558,17 +571,18 @@ contains
     type(psb_ctxt_type) :: ctxt
     integer(psb_ipk_)   :: il, nl, iam, np
 
-
     avgcr = dzero
+    nl = prec%get_nlevs()
+    do il=2,nl
+      if (prec%precv(il)%base_desc%is_ok()) then 
+        ctxt = prec%precv(il)%base_desc%get_ctxt()
+        call psb_info(ctxt,iam,np)
+        if (iam >=0)  avgcr = avgcr + max(dzero,prec%precv(il)%szratio)
+      end if
+    end do
+    avgcr = avgcr / (nl-1)
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    if (allocated(prec%precv)) then
-      nl = size(prec%precv)
-      do il=2,nl
-        avgcr = avgcr + max(dzero,prec%precv(il)%szratio)
-      end do
-      avgcr = avgcr / (nl-1)
-    end if
     call psb_sum(ctxt,avgcr)
     prec%ag_data%avg_cr = avgcr/np
   end subroutine amg_z_cmp_avg_cr
@@ -586,9 +600,7 @@ contains
   !             error code.
   !
   subroutine amg_zprecfree(p,info)
-
     implicit none
-
     ! Arguments
     type(amg_zprec_type), intent(inout) :: p
     integer(psb_ipk_), intent(out)        :: info
@@ -614,9 +626,7 @@ contains
   end subroutine amg_zprecfree
 
   subroutine amg_z_prec_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_zprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -653,9 +663,7 @@ contains
   end subroutine amg_z_prec_free
 
   subroutine amg_z_smoothers_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_zprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -672,7 +680,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      do i=1,size(prec%precv)
+      do i=1,prec%get_nlevs()
         call prec%precv(i)%free_smoothers(info)
       end do
     end if
@@ -686,9 +694,7 @@ contains
   end subroutine amg_z_smoothers_free
 
   subroutine amg_z_hierarchy_free(prec,info)
-
     implicit none
-
     ! Arguments
     class(amg_zprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -715,7 +721,6 @@ contains
 
   end subroutine amg_z_hierarchy_free
 
-
   !
   ! Top level methods.
   !
@@ -780,7 +785,6 @@ contains
 
   end subroutine amg_z_apply1_vect
 
-
   subroutine amg_z_apply2v(prec,x,y,desc_data,info,trans,work)
     implicit none
     type(psb_desc_type),intent(in)    :: desc_data
@@ -845,7 +849,6 @@ contains
   subroutine amg_z_dump(prec,info,istart,iend,iproc,prefix,head,&
        & ac,rp,smoother,solver,tprol,&
        & global_num)
-
     implicit none
     class(amg_zprec_type), intent(in)     :: prec
     integer(psb_ipk_), intent(out)          :: info
@@ -862,7 +865,7 @@ contains
     info = 0
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    iln = size(prec%precv)
+    iln = prec%get_nlevs()
     if (present(istart)) then
       il1 = max(1,istart)
     else
@@ -886,7 +889,6 @@ contains
   end subroutine amg_z_dump
 
   subroutine amg_z_cnv(prec,info,amold,vmold,imold)
-
     implicit none
     class(amg_zprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)       :: info
@@ -898,7 +900,7 @@ contains
 
     info = psb_success_
     if (allocated(prec%precv)) then
-      do i=1,size(prec%precv)
+      do i=1,prec%get_nlevs()
         if (info == psb_success_ ) &
              & call prec%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
       end do
@@ -907,7 +909,6 @@ contains
   end subroutine amg_z_cnv
 
   subroutine amg_z_clone(prec,precout,info)
-
     implicit none
     class(amg_zprec_type), intent(inout) :: prec
     class(psb_zprec_type), intent(inout) :: precout
@@ -919,7 +920,6 @@ contains
   end subroutine amg_z_clone
 
   subroutine amg_z_inner_clone(prec,precout,info)
-
     implicit none
     class(amg_zprec_type), intent(inout)         :: prec
     class(psb_zprec_type), target, intent(inout) :: precout
@@ -935,8 +935,9 @@ contains
       pout%ctxt          = prec%ctxt
       pout%ag_data       = prec%ag_data
       pout%outer_sweeps  = prec%outer_sweeps
+      pout%nlevs         = prec%nlevs
       if (allocated(prec%precv)) then
-        ln = size(prec%precv)
+        ln = prec%get_nlevs()
         allocate(pout%precv(ln),stat=info)
         if (info /= psb_success_) goto 9999
         if (ln >= 1) then
@@ -944,6 +945,7 @@ contains
         end if
         do lev=2, ln
           if (info /= psb_success_) exit
+!!$          write(0,*) 'Inner_clone must be checked and reimplemented! '
           call prec%precv(lev)%clone(pout%precv(lev),info)
           if (info == psb_success_) then
             pout%precv(lev)%base_a       => pout%precv(lev)%ac
@@ -1023,7 +1025,7 @@ contains
     if (psb_errstatus_fatal()) then
       info = psb_err_internal_error_; goto 9999
     end if
-    nlev   = size(prec%precv)
+    nlev   = prec%get_nlevs()
     level = 1
     do level = 1, nlev
       call prec%precv(level)%allocate_wrk(info,vmold=vmold)
@@ -1046,7 +1048,6 @@ contains
   subroutine amg_z_free_wrk(prec,info)
     use psb_base_mod
     implicit none
-
     ! Arguments
     class(amg_zprec_type), intent(inout) :: prec
     integer(psb_ipk_), intent(out)        :: info
@@ -1063,7 +1064,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      nlev   = size(prec%precv)
+      nlev   = prec%get_nlevs()
       do level = 1, nlev
         call prec%precv(level)%free_wrk(info)
       end do

amgprec/impl/Makefile

@@ -25,22 +25,22 @@ MPCOBJS=amg_dslud_interface.o amg_zslud_interface.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   \
+	amg_dmlprec_aply.o amg_dmlprec_aply_a.o \
 	$(DMPFOBJS) amg_d_extprol_bld.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   \
+	amg_smlprec_aply.o amg_smlprec_aply_a.o \
 	$(SMPFOBJS) amg_s_extprol_bld.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   \
+	amg_zmlprec_aply.o amg_zmlprec_aply_a.o \
 	$(ZMPFOBJS)  amg_z_extprol_bld.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   \
+	amg_cmlprec_aply.o amg_cmlprec_aply_a.o \
 	$(CMPFOBJS)  amg_c_extprol_bld.o
 
 INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS)

amgprec/impl/aggregator/amg_c_dec_aggregator_mat_asb.f90

@@ -114,63 +114,67 @@ subroutine  amg_c_dec_aggregator_mat_asb(ag,parms,a,desc_a,&
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  
+  if (me >=0) then 
+    select case(parms%coarse_mat)
 
-  select case(parms%coarse_mat)
+    case(amg_distr_mat_) 
 
-  case(amg_distr_mat_) 
+      call ac%cscnv(info,type='csr')
+      call op_prol%cscnv(info,type='csr')
+      call op_restr%cscnv(info,type='csr')
 
-    call ac%cscnv(info,type='csr')
-    call op_prol%cscnv(info,type='csr')
-    call op_restr%cscnv(info,type='csr')
+      if (debug_level >= psb_debug_outer_) &
+           & write(debug_unit,*) me,' ',trim(name),&
+           & 'Done ac '
 
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Done ac '
+    case(amg_repl_mat_) 
+      !
+      ! We are assuming here that an c matrix
+      ! can hold all entries
+      !
+      if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
+        ntaggr = desc_ac%get_global_rows()
+        i_nr   = ntaggr
+      else
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
+        goto 9999
+      end if
 
-  case(amg_repl_mat_) 
-    !
-    ! We are assuming here that an c matrix
-    ! can hold all entries
-    !
-    if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
-      ntaggr = desc_ac%get_global_rows()
-      i_nr   = ntaggr
-    else
+      call op_prol%mv_to(tmpcoo)
+      nzl = tmpcoo%get_nzeros()
+      call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
+      call tmpcoo%set_ncols(i_nr)
+      call op_prol%mv_from(tmpcoo)
+
+      call op_restr%mv_to(tmpcoo)
+      nzl = tmpcoo%get_nzeros()
+      call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
+      call tmpcoo%set_nrows(i_nr)
+      call op_restr%mv_from(tmpcoo)
+
+
+      call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
+           & dupl=psb_dupl_add_,keeploc=.false.)
+      call tmp_ac%mv_to(tmpcoo)
+      call ac%mv_from(tmpcoo)
+
+      call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.)
+      if (info == psb_success_) call psb_cdasb(desc_ac,info)
+
+      if (info /= psb_success_) goto 9999
+
+    case default 
       info = psb_err_internal_error_
       call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
       goto 9999
-    end if
-    
-    call op_prol%mv_to(tmpcoo)
-    nzl = tmpcoo%get_nzeros()
-    call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
-    call tmpcoo%set_ncols(i_nr)
-    call op_prol%mv_from(tmpcoo)
-
-    call op_restr%mv_to(tmpcoo)
-    nzl = tmpcoo%get_nzeros()
-    call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
-    call tmpcoo%set_nrows(i_nr)
-    call op_restr%mv_from(tmpcoo)
-
-
-    call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
-         & dupl=psb_dupl_add_,keeploc=.false.)
-    call tmp_ac%mv_to(tmpcoo)
-    call ac%mv_from(tmpcoo)
-    
-    call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.)
-    if (info == psb_success_) call psb_cdasb(desc_ac,info)
-
-    if (info /= psb_success_) goto 9999
-
-  case default 
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
-    goto 9999
-  end select
-
-
+    end select
+  else
+    call op_prol%allocate(izero,izero,info)
+    call op_restr%allocate(izero,izero,info)
+    call ac%allocate(izero,izero,info)
+  end if
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_c_dec_aggregator_mat_bld.f90

@@ -139,7 +139,7 @@ subroutine  amg_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   use amg_c_prec_type, amg_protect_name => amg_c_dec_aggregator_mat_bld
   use amg_c_inner_mod 
   implicit none
-  
+
   class(amg_c_dec_aggregator_type), target, intent(inout) :: ag
   type(amg_sml_parms), intent(inout)      :: parms 
   type(psb_cspmat_type), intent(in)    :: a
@@ -169,39 +169,46 @@ subroutine  amg_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
 
-  !
-  ! Build the coarse-level matrix from the fine-level one, starting from 
-  ! the mapping defined by amg_aggrmap_bld and applying the aggregation
-  ! algorithm specified by 
-  !
-  select case (parms%aggr_prol)
-  case (amg_no_smooth_) 
+  if (me >=0) then 
+    !
+    ! Build the coarse-level matrix from the fine-level one, starting from 
+    ! the mapping defined by amg_aggrmap_bld and applying the aggregation
+    ! algorithm specified by 
+    !
+    select case (parms%aggr_prol)
+    case (amg_no_smooth_) 
 
-    call amg_caggrmat_nosmth_bld(parms%aggr_prol,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_,amg_l1_smooth_prol_) 
+    case(amg_smooth_prol_,amg_l1_smooth_prol_) 
 
-    call amg_caggrmat_smth_bld(parms%aggr_prol,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(parms%aggr_prol,a,desc_a,ilaggr,&
-            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    case(amg_min_energy_) 
 
-  case default
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='Invalid aggr kind')
-    goto 9999
+      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_
+      call psb_errpush(info,name,a_err='Invalid aggr kind')
+      goto 9999
+
+    end select
+  else
+    call op_prol%allocate(izero,izero,info)
+    call op_restr%allocate(izero,izero,info)
+    call ac%allocate(izero,izero,info)
+  end if
 
-  end select
   if (info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld')
     goto 9999
@@ -214,5 +221,5 @@ subroutine  amg_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
 9999 call psb_error_handler(err_act)
   return
 
-  
+
 end subroutine amg_c_dec_aggregator_mat_bld

amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90

@@ -122,19 +122,23 @@ subroutine  amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
   call amg_check_def(parms%aggr_ord,'Ordering',&
        &   amg_aggr_ord_nat_,is_legal_ml_aggr_ord)
   call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
+  if (me >=0) then 
+    !
+    ! The decoupled aggregator based on SOC measures ignores
+    ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
+    !
+    if (do_timings) call psb_tic(idx_map_bld)
+    clean_zeros = ag%do_clean_zeros
+    call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+    if (do_timings) call psb_toc(idx_map_bld)
+    if (do_timings) call psb_tic(idx_map_tprol)
 
-  !
-  ! The decoupled aggregator based on SOC measures ignores
-  ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
-  !
-  if (do_timings) call psb_tic(idx_map_bld)
-  clean_zeros = ag%do_clean_zeros
-  call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
-  if (do_timings) call psb_toc(idx_map_bld)
-  if (do_timings) call psb_tic(idx_map_tprol)
-
-  if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
-  if (do_timings) call psb_toc(idx_map_tprol)
+    if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+    if (do_timings) call psb_toc(idx_map_tprol)
+  else
+    allocate(nlaggr(0),ilaggr(0))
+    call t_prol%allocate(lzero,lzero,info)
+  end if
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_d_dec_aggregator_mat_asb.f90

@@ -114,63 +114,67 @@ subroutine  amg_d_dec_aggregator_mat_asb(ag,parms,a,desc_a,&
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  
+  if (me >=0) then 
+    select case(parms%coarse_mat)
 
-  select case(parms%coarse_mat)
+    case(amg_distr_mat_) 
 
-  case(amg_distr_mat_) 
+      call ac%cscnv(info,type='csr')
+      call op_prol%cscnv(info,type='csr')
+      call op_restr%cscnv(info,type='csr')
 
-    call ac%cscnv(info,type='csr')
-    call op_prol%cscnv(info,type='csr')
-    call op_restr%cscnv(info,type='csr')
+      if (debug_level >= psb_debug_outer_) &
+           & write(debug_unit,*) me,' ',trim(name),&
+           & 'Done ac '
 
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Done ac '
+    case(amg_repl_mat_) 
+      !
+      ! We are assuming here that an d matrix
+      ! can hold all entries
+      !
+      if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
+        ntaggr = desc_ac%get_global_rows()
+        i_nr   = ntaggr
+      else
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
+        goto 9999
+      end if
 
-  case(amg_repl_mat_) 
-    !
-    ! We are assuming here that an d matrix
-    ! can hold all entries
-    !
-    if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
-      ntaggr = desc_ac%get_global_rows()
-      i_nr   = ntaggr
-    else
+      call op_prol%mv_to(tmpcoo)
+      nzl = tmpcoo%get_nzeros()
+      call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
+      call tmpcoo%set_ncols(i_nr)
+      call op_prol%mv_from(tmpcoo)
+
+      call op_restr%mv_to(tmpcoo)
+      nzl = tmpcoo%get_nzeros()
+      call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
+      call tmpcoo%set_nrows(i_nr)
+      call op_restr%mv_from(tmpcoo)
+
+
+      call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
+           & dupl=psb_dupl_add_,keeploc=.false.)
+      call tmp_ac%mv_to(tmpcoo)
+      call ac%mv_from(tmpcoo)
+
+      call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.)
+      if (info == psb_success_) call psb_cdasb(desc_ac,info)
+
+      if (info /= psb_success_) goto 9999
+
+    case default 
       info = psb_err_internal_error_
       call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
       goto 9999
-    end if
-    
-    call op_prol%mv_to(tmpcoo)
-    nzl = tmpcoo%get_nzeros()
-    call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
-    call tmpcoo%set_ncols(i_nr)
-    call op_prol%mv_from(tmpcoo)
-
-    call op_restr%mv_to(tmpcoo)
-    nzl = tmpcoo%get_nzeros()
-    call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
-    call tmpcoo%set_nrows(i_nr)
-    call op_restr%mv_from(tmpcoo)
-
-
-    call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
-         & dupl=psb_dupl_add_,keeploc=.false.)
-    call tmp_ac%mv_to(tmpcoo)
-    call ac%mv_from(tmpcoo)
-    
-    call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.)
-    if (info == psb_success_) call psb_cdasb(desc_ac,info)
-
-    if (info /= psb_success_) goto 9999
-
-  case default 
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
-    goto 9999
-  end select
-
-
+    end select
+  else
+    call op_prol%allocate(izero,izero,info)
+    call op_restr%allocate(izero,izero,info)
+    call ac%allocate(izero,izero,info)
+  end if
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_d_dec_aggregator_mat_bld.f90

@@ -139,7 +139,7 @@ subroutine  amg_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   use amg_d_prec_type, amg_protect_name => amg_d_dec_aggregator_mat_bld
   use amg_d_inner_mod 
   implicit none
-  
+
   class(amg_d_dec_aggregator_type), target, intent(inout) :: ag
   type(amg_dml_parms), intent(inout)      :: parms 
   type(psb_dspmat_type), intent(in)    :: a
@@ -169,39 +169,46 @@ subroutine  amg_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
 
-  !
-  ! Build the coarse-level matrix from the fine-level one, starting from 
-  ! the mapping defined by amg_aggrmap_bld and applying the aggregation
-  ! algorithm specified by 
-  !
-  select case (parms%aggr_prol)
-  case (amg_no_smooth_) 
+  if (me >=0) then 
+    !
+    ! Build the coarse-level matrix from the fine-level one, starting from 
+    ! the mapping defined by amg_aggrmap_bld and applying the aggregation
+    ! algorithm specified by 
+    !
+    select case (parms%aggr_prol)
+    case (amg_no_smooth_) 
 
-    call amg_daggrmat_nosmth_bld(parms%aggr_prol,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_,amg_l1_smooth_prol_) 
+    case(amg_smooth_prol_,amg_l1_smooth_prol_) 
 
-    call amg_daggrmat_smth_bld(parms%aggr_prol,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(parms%aggr_prol,a,desc_a,ilaggr,&
-            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    case(amg_min_energy_) 
 
-  case default
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='Invalid aggr kind')
-    goto 9999
+      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_
+      call psb_errpush(info,name,a_err='Invalid aggr kind')
+      goto 9999
+
+    end select
+  else
+    call op_prol%allocate(izero,izero,info)
+    call op_restr%allocate(izero,izero,info)
+    call ac%allocate(izero,izero,info)
+  end if
 
-  end select
   if (info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld')
     goto 9999
@@ -214,5 +221,5 @@ subroutine  amg_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
 9999 call psb_error_handler(err_act)
   return
 
-  
+
 end subroutine amg_d_dec_aggregator_mat_bld

amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90

@@ -122,19 +122,23 @@ subroutine  amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
   call amg_check_def(parms%aggr_ord,'Ordering',&
        &   amg_aggr_ord_nat_,is_legal_ml_aggr_ord)
   call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs)
+  if (me >=0) then 
+    !
+    ! The decoupled aggregator based on SOC measures ignores
+    ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
+    !
+    if (do_timings) call psb_tic(idx_map_bld)
+    clean_zeros = ag%do_clean_zeros
+    call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+    if (do_timings) call psb_toc(idx_map_bld)
+    if (do_timings) call psb_tic(idx_map_tprol)
 
-  !
-  ! The decoupled aggregator based on SOC measures ignores
-  ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
-  !
-  if (do_timings) call psb_tic(idx_map_bld)
-  clean_zeros = ag%do_clean_zeros
-  call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
-  if (do_timings) call psb_toc(idx_map_bld)
-  if (do_timings) call psb_tic(idx_map_tprol)
-
-  if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
-  if (do_timings) call psb_toc(idx_map_tprol)
+    if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+    if (do_timings) call psb_toc(idx_map_tprol)
+  else
+    allocate(nlaggr(0),ilaggr(0))
+    call t_prol%allocate(lzero,lzero,info)
+  end if
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_s_dec_aggregator_mat_asb.f90

@@ -114,63 +114,67 @@ subroutine  amg_s_dec_aggregator_mat_asb(ag,parms,a,desc_a,&
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  
+  if (me >=0) then 
+    select case(parms%coarse_mat)
 
-  select case(parms%coarse_mat)
+    case(amg_distr_mat_) 
 
-  case(amg_distr_mat_) 
+      call ac%cscnv(info,type='csr')
+      call op_prol%cscnv(info,type='csr')
+      call op_restr%cscnv(info,type='csr')
 
-    call ac%cscnv(info,type='csr')
-    call op_prol%cscnv(info,type='csr')
-    call op_restr%cscnv(info,type='csr')
+      if (debug_level >= psb_debug_outer_) &
+           & write(debug_unit,*) me,' ',trim(name),&
+           & 'Done ac '
 
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Done ac '
+    case(amg_repl_mat_) 
+      !
+      ! We are assuming here that an s matrix
+      ! can hold all entries
+      !
+      if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
+        ntaggr = desc_ac%get_global_rows()
+        i_nr   = ntaggr
+      else
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
+        goto 9999
+      end if
 
-  case(amg_repl_mat_) 
-    !
-    ! We are assuming here that an s matrix
-    ! can hold all entries
-    !
-    if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
-      ntaggr = desc_ac%get_global_rows()
-      i_nr   = ntaggr
-    else
+      call op_prol%mv_to(tmpcoo)
+      nzl = tmpcoo%get_nzeros()
+      call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
+      call tmpcoo%set_ncols(i_nr)
+      call op_prol%mv_from(tmpcoo)
+
+      call op_restr%mv_to(tmpcoo)
+      nzl = tmpcoo%get_nzeros()
+      call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
+      call tmpcoo%set_nrows(i_nr)
+      call op_restr%mv_from(tmpcoo)
+
+
+      call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
+           & dupl=psb_dupl_add_,keeploc=.false.)
+      call tmp_ac%mv_to(tmpcoo)
+      call ac%mv_from(tmpcoo)
+
+      call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.)
+      if (info == psb_success_) call psb_cdasb(desc_ac,info)
+
+      if (info /= psb_success_) goto 9999
+
+    case default 
       info = psb_err_internal_error_
       call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
       goto 9999
-    end if
-    
-    call op_prol%mv_to(tmpcoo)
-    nzl = tmpcoo%get_nzeros()
-    call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
-    call tmpcoo%set_ncols(i_nr)
-    call op_prol%mv_from(tmpcoo)
-
-    call op_restr%mv_to(tmpcoo)
-    nzl = tmpcoo%get_nzeros()
-    call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
-    call tmpcoo%set_nrows(i_nr)
-    call op_restr%mv_from(tmpcoo)
-
-
-    call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
-         & dupl=psb_dupl_add_,keeploc=.false.)
-    call tmp_ac%mv_to(tmpcoo)
-    call ac%mv_from(tmpcoo)
-    
-    call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.)
-    if (info == psb_success_) call psb_cdasb(desc_ac,info)
-
-    if (info /= psb_success_) goto 9999
-
-  case default 
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
-    goto 9999
-  end select
-
-
+    end select
+  else
+    call op_prol%allocate(izero,izero,info)
+    call op_restr%allocate(izero,izero,info)
+    call ac%allocate(izero,izero,info)
+  end if
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_s_dec_aggregator_mat_bld.f90

@@ -139,7 +139,7 @@ subroutine  amg_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   use amg_s_prec_type, amg_protect_name => amg_s_dec_aggregator_mat_bld
   use amg_s_inner_mod 
   implicit none
-  
+
   class(amg_s_dec_aggregator_type), target, intent(inout) :: ag
   type(amg_sml_parms), intent(inout)      :: parms 
   type(psb_sspmat_type), intent(in)    :: a
@@ -169,39 +169,46 @@ subroutine  amg_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
 
-  !
-  ! Build the coarse-level matrix from the fine-level one, starting from 
-  ! the mapping defined by amg_aggrmap_bld and applying the aggregation
-  ! algorithm specified by 
-  !
-  select case (parms%aggr_prol)
-  case (amg_no_smooth_) 
+  if (me >=0) then 
+    !
+    ! Build the coarse-level matrix from the fine-level one, starting from 
+    ! the mapping defined by amg_aggrmap_bld and applying the aggregation
+    ! algorithm specified by 
+    !
+    select case (parms%aggr_prol)
+    case (amg_no_smooth_) 
 
-    call amg_saggrmat_nosmth_bld(parms%aggr_prol,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_,amg_l1_smooth_prol_) 
+    case(amg_smooth_prol_,amg_l1_smooth_prol_) 
 
-    call amg_saggrmat_smth_bld(parms%aggr_prol,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(parms%aggr_prol,a,desc_a,ilaggr,&
-            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    case(amg_min_energy_) 
 
-  case default
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='Invalid aggr kind')
-    goto 9999
+      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_
+      call psb_errpush(info,name,a_err='Invalid aggr kind')
+      goto 9999
+
+    end select
+  else
+    call op_prol%allocate(izero,izero,info)
+    call op_restr%allocate(izero,izero,info)
+    call ac%allocate(izero,izero,info)
+  end if
 
-  end select
   if (info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld')
     goto 9999
@@ -214,5 +221,5 @@ subroutine  amg_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
 9999 call psb_error_handler(err_act)
   return
 
-  
+
 end subroutine amg_s_dec_aggregator_mat_bld

amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90

@@ -122,19 +122,23 @@ subroutine  amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
   call amg_check_def(parms%aggr_ord,'Ordering',&
        &   amg_aggr_ord_nat_,is_legal_ml_aggr_ord)
   call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
+  if (me >=0) then 
+    !
+    ! The decoupled aggregator based on SOC measures ignores
+    ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
+    !
+    if (do_timings) call psb_tic(idx_map_bld)
+    clean_zeros = ag%do_clean_zeros
+    call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+    if (do_timings) call psb_toc(idx_map_bld)
+    if (do_timings) call psb_tic(idx_map_tprol)
 
-  !
-  ! The decoupled aggregator based on SOC measures ignores
-  ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
-  !
-  if (do_timings) call psb_tic(idx_map_bld)
-  clean_zeros = ag%do_clean_zeros
-  call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
-  if (do_timings) call psb_toc(idx_map_bld)
-  if (do_timings) call psb_tic(idx_map_tprol)
-
-  if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
-  if (do_timings) call psb_toc(idx_map_tprol)
+    if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+    if (do_timings) call psb_toc(idx_map_tprol)
+  else
+    allocate(nlaggr(0),ilaggr(0))
+    call t_prol%allocate(lzero,lzero,info)
+  end if
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_z_dec_aggregator_mat_asb.f90

@@ -114,63 +114,67 @@ subroutine  amg_z_dec_aggregator_mat_asb(ag,parms,a,desc_a,&
   info  = psb_success_
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
+  
+  if (me >=0) then 
+    select case(parms%coarse_mat)
 
-  select case(parms%coarse_mat)
+    case(amg_distr_mat_) 
 
-  case(amg_distr_mat_) 
+      call ac%cscnv(info,type='csr')
+      call op_prol%cscnv(info,type='csr')
+      call op_restr%cscnv(info,type='csr')
 
-    call ac%cscnv(info,type='csr')
-    call op_prol%cscnv(info,type='csr')
-    call op_restr%cscnv(info,type='csr')
+      if (debug_level >= psb_debug_outer_) &
+           & write(debug_unit,*) me,' ',trim(name),&
+           & 'Done ac '
 
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Done ac '
+    case(amg_repl_mat_) 
+      !
+      ! We are assuming here that an z matrix
+      ! can hold all entries
+      !
+      if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
+        ntaggr = desc_ac%get_global_rows()
+        i_nr   = ntaggr
+      else
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
+        goto 9999
+      end if
 
-  case(amg_repl_mat_) 
-    !
-    ! We are assuming here that an z matrix
-    ! can hold all entries
-    !
-    if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
-      ntaggr = desc_ac%get_global_rows()
-      i_nr   = ntaggr
-    else
+      call op_prol%mv_to(tmpcoo)
+      nzl = tmpcoo%get_nzeros()
+      call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
+      call tmpcoo%set_ncols(i_nr)
+      call op_prol%mv_from(tmpcoo)
+
+      call op_restr%mv_to(tmpcoo)
+      nzl = tmpcoo%get_nzeros()
+      call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
+      call tmpcoo%set_nrows(i_nr)
+      call op_restr%mv_from(tmpcoo)
+
+
+      call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
+           & dupl=psb_dupl_add_,keeploc=.false.)
+      call tmp_ac%mv_to(tmpcoo)
+      call ac%mv_from(tmpcoo)
+
+      call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.)
+      if (info == psb_success_) call psb_cdasb(desc_ac,info)
+
+      if (info /= psb_success_) goto 9999
+
+    case default 
       info = psb_err_internal_error_
       call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
       goto 9999
-    end if
-    
-    call op_prol%mv_to(tmpcoo)
-    nzl = tmpcoo%get_nzeros()
-    call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
-    call tmpcoo%set_ncols(i_nr)
-    call op_prol%mv_from(tmpcoo)
-
-    call op_restr%mv_to(tmpcoo)
-    nzl = tmpcoo%get_nzeros()
-    call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
-    call tmpcoo%set_nrows(i_nr)
-    call op_restr%mv_from(tmpcoo)
-
-
-    call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
-         & dupl=psb_dupl_add_,keeploc=.false.)
-    call tmp_ac%mv_to(tmpcoo)
-    call ac%mv_from(tmpcoo)
-    
-    call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.)
-    if (info == psb_success_) call psb_cdasb(desc_ac,info)
-
-    if (info /= psb_success_) goto 9999
-
-  case default 
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
-    goto 9999
-  end select
-
-
+    end select
+  else
+    call op_prol%allocate(izero,izero,info)
+    call op_restr%allocate(izero,izero,info)
+    call ac%allocate(izero,izero,info)
+  end if
   call psb_erractionrestore(err_act)
   return
 

amgprec/impl/aggregator/amg_z_dec_aggregator_mat_bld.f90

@@ -139,7 +139,7 @@ subroutine  amg_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   use amg_z_prec_type, amg_protect_name => amg_z_dec_aggregator_mat_bld
   use amg_z_inner_mod 
   implicit none
-  
+
   class(amg_z_dec_aggregator_type), target, intent(inout) :: ag
   type(amg_dml_parms), intent(inout)      :: parms 
   type(psb_zspmat_type), intent(in)    :: a
@@ -169,39 +169,46 @@ subroutine  amg_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
   ctxt = desc_a%get_context()
   call psb_info(ctxt,me,np)
 
-  !
-  ! Build the coarse-level matrix from the fine-level one, starting from 
-  ! the mapping defined by amg_aggrmap_bld and applying the aggregation
-  ! algorithm specified by 
-  !
-  select case (parms%aggr_prol)
-  case (amg_no_smooth_) 
+  if (me >=0) then 
+    !
+    ! Build the coarse-level matrix from the fine-level one, starting from 
+    ! the mapping defined by amg_aggrmap_bld and applying the aggregation
+    ! algorithm specified by 
+    !
+    select case (parms%aggr_prol)
+    case (amg_no_smooth_) 
 
-    call amg_zaggrmat_nosmth_bld(parms%aggr_prol,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_,amg_l1_smooth_prol_) 
+    case(amg_smooth_prol_,amg_l1_smooth_prol_) 
 
-    call amg_zaggrmat_smth_bld(parms%aggr_prol,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(parms%aggr_prol,a,desc_a,ilaggr,&
-            nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
+    case(amg_min_energy_) 
 
-  case default
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='Invalid aggr kind')
-    goto 9999
+      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_
+      call psb_errpush(info,name,a_err='Invalid aggr kind')
+      goto 9999
+
+    end select
+  else
+    call op_prol%allocate(izero,izero,info)
+    call op_restr%allocate(izero,izero,info)
+    call ac%allocate(izero,izero,info)
+  end if
 
-  end select
   if (info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld')
     goto 9999
@@ -214,5 +221,5 @@ subroutine  amg_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
 9999 call psb_error_handler(err_act)
   return
 
-  
+
 end subroutine amg_z_dec_aggregator_mat_bld

amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90

@@ -122,19 +122,23 @@ subroutine  amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
   call amg_check_def(parms%aggr_ord,'Ordering',&
        &   amg_aggr_ord_nat_,is_legal_ml_aggr_ord)
   call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs)
+  if (me >=0) then 
+    !
+    ! The decoupled aggregator based on SOC measures ignores
+    ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
+    !
+    if (do_timings) call psb_tic(idx_map_bld)
+    clean_zeros = ag%do_clean_zeros
+    call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+    if (do_timings) call psb_toc(idx_map_bld)
+    if (do_timings) call psb_tic(idx_map_tprol)
 
-  !
-  ! The decoupled aggregator based on SOC measures ignores
-  ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
-  !
-  if (do_timings) call psb_tic(idx_map_bld)
-  clean_zeros = ag%do_clean_zeros
-  call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
-  if (do_timings) call psb_toc(idx_map_bld)
-  if (do_timings) call psb_tic(idx_map_tprol)
-
-  if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
-  if (do_timings) call psb_toc(idx_map_tprol)
+    if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+    if (do_timings) call psb_toc(idx_map_tprol)
+  else
+    allocate(nlaggr(0),ilaggr(0))
+    call t_prol%allocate(lzero,lzero,info)
+  end if
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/amg_c_hierarchy_bld.F90

@@ -64,11 +64,9 @@
 !               Error code.              
 !  
 subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
-
   use psb_base_mod
   use amg_c_inner_mod
   use amg_c_prec_mod, amg_protect_name => amg_c_hierarchy_bld
-
   Implicit None
 
   ! Arguments
@@ -82,7 +80,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: me,np
   integer(psb_ipk_)   :: err,i,k, err_act, iszv, newsz,&
-       & nplevs, mxplevs
+       & nplevs, mxplevs, level
   integer(psb_lpk_) :: iaggsize, casize, mncsize, mncszpp
   real(psb_spk_)     :: mnaggratio, sizeratio, athresh, aomega
   class(amg_c_base_smoother_type), allocatable :: coarse_sm, med_sm, &
@@ -98,6 +96,9 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
   character(len=40)  :: ch_err
   integer(psb_ipk_), save  :: idx_bldtp=-1, idx_matasb=-1
   logical, parameter :: do_timings=.false.
+  logical             :: stop_hierarchy_loop
+  type(psb_ctxt_type) :: lctxt
+  integer(psb_ipk_)   :: lme,lnp
 
   info=psb_success_
   err=0
@@ -130,7 +131,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
   end if
   cpymat_ = .false.
   if (present(cpymat)) cpymat_ = cpymat
-  
+
   !
   ! Check to ensure all procs have the same 
   !   
@@ -139,7 +140,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
   mnaggratio = prec%ag_data%min_cr_ratio
   mncsize    = prec%ag_data%min_coarse_size
   mncszpp    = prec%ag_data%min_coarse_size_per_process
-  iszv       = size(prec%precv)
+  iszv       = prec%get_nlevs()
   call psb_bcast(ctxt,iszv)
   call psb_bcast(ctxt,mncsize)
   call psb_bcast(ctxt,mncszpp)
@@ -165,7 +166,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
     call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
     goto 9999
   end if
-  if (iszv /= size(prec%precv)) then 
+  if (iszv /= prec%get_nlevs()) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999
@@ -180,6 +181,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
     call psb_errpush(info,name,a_err=ch_err)
     goto 9999
   endif
+
   if (iszv == 1) then
     !
     ! This is OK, since it may be called by the user even if there
@@ -227,7 +229,6 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
     casize = mncsize
   end if
   prec%ag_data%target_coarse_size = casize
-  
   nplevs = max(itwo,mxplevs)
 
   !
@@ -240,7 +241,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   end if
   !
-  ! First set desired number of levels
+  ! First set desired number of levels if different from default. 
   !
   if (iszv /= nplevs) then
     allocate(tprecv(nplevs),stat=info)
@@ -286,7 +287,8 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
       call prec%precv(i)%free(info)
     end do
     call move_alloc(tprecv,prec%precv)
-    iszv = size(prec%precv)
+    call prec%set_nlevs(nplevs)
+    iszv = prec%get_nlevs()
   end if
 
   !
@@ -301,15 +303,24 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
   end if
   call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
   prec%precv(1)%base_desc => prec%precv(1)%desc_ac
-  
+
+  !
+  ! Main build loop
+  !   
   newsz = 0
+  stop_hierarchy_loop = .false. 
   array_build_loop: do i=2, iszv
     !
     ! Check on the iprcparm contents: they should be the same
     ! on all processes.
     !
     call psb_bcast(ctxt,prec%precv(i)%parms)
-
+    !
+    ! Get current context: might have performed remapping
+    ! 
+    lctxt = prec%precv(i-1)%base_desc%get_ctxt()
+    call psb_info(lctxt,lme,lnp)
+!!$    write(0,*) 'Check at level',i,lme,lnp
     !
     ! Sanity checks on the parameters
     !
@@ -325,8 +336,8 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
          & write(debug_unit,*) me,' ',trim(name),&
          & 'Calling mlprcbld at level  ',i
     !
-    ! Build the mapping between levels i-1 and i and the matrix
-    ! at level i
+    ! Build the tentative mapping between levels i-1 and i
+    ! and the matrix at level i
     !
     if (do_timings) call psb_tic(idx_bldtp)
     if (info == psb_success_)&
@@ -348,47 +359,26 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
     ! Save op_prol just in case
     !
     call op_prol%clone(prec%precv(i)%tprol,info)
+
     !
     ! Check for early termination of aggregation loop. 
-    !      
-    iaggsize = sum(nlaggr)
-
-    sizeratio = iaggsize
-    if (i==2) then 
-      sizeratio = desc_a%get_global_rows()/sizeratio
+    !
+    if (i == 2) then 
+      call amg_c_hierarchy_bld_cmp_newsz(i,iszv,&
+           & desc_a%get_global_rows(),&
+           & nlaggr,casize,mnaggratio,sizeratio,newsz)
     else
-      sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
+      call amg_c_hierarchy_bld_cmp_newsz(i,iszv,&
+           & sum(prec%precv(i-1)%linmap%naggr),&
+           & nlaggr,casize,mnaggratio,sizeratio,newsz)
     end if
     prec%precv(i)%szratio = sizeratio
-
-    if (iaggsize <= casize) newsz = i      
-    if (i == iszv)          newsz = i
-
-    if (i>2) then
-      if (sizeratio < mnaggratio) then
-        !
-        ! We are not gaining 
-        !
-        newsz = i-1
-      end if
-
-      if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then 
-        newsz=i-1
-        if (me == 0) then 
-          write(debug_unit,*) trim(name),&
-               &': Warning: aggregates from level ',&
-               & newsz
-          write(debug_unit,*) trim(name),&
-               &':                       to level ',&
-               & iszv,' coincide.'
-          write(debug_unit,*) trim(name),&
-               &': Number of levels actually used :',newsz
-          write(debug_unit,*)
-        end if
-      end if
-    end if
     call psb_bcast(ctxt,newsz)
 
+    !
+    ! Handle reallocation, if needed, and then mat_asb to polish off the
+    ! construction
+    ! 
     if (newsz > 0) then
       !
       ! This is awkward, we are saving the aggregation parms, for the sake
@@ -422,92 +412,102 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
              & a_err=ch_err)
         goto 9999
       endif
-      exit array_build_loop
+!!$      write(0,*) ' Early exit  of array_build_loop',i,iszv,info,&
+      level = newsz
+      stop_hierarchy_loop = .true. 
     else
-      if (do_timings) call psb_tic(idx_matasb)            
+      if (do_timings) call psb_tic(idx_matasb)
       if (info == psb_success_) call prec%precv(i)%mat_asb(&
            & prec%precv(i-1)%base_a,prec%precv(i-1)%base_desc,&
            & ilaggr,nlaggr,op_prol,info)
       if (do_timings) call psb_toc(idx_matasb)      
+      level = i
     end if
+
+    !
+    ! Do we want to remap onto a smaller subset of processes?
+    ! Will need a more sophisticated policy
+    !
+    block
+      type(psb_ctxt_type) :: lctxt
+      integer(psb_ipk_)   :: lme,lnp
+      lctxt = prec%precv(level)%desc_ac%get_ctxt()
+      call psb_info(lctxt,lme,lnp)
+      if (amg_c_policy_do_remap(lctxt,level,sum(nlaggr))) then 
+!!$        write(0,*) ' Context on remapping ',lme,lnp
+        if ((lme >=0).and.(lnp>=2)) then 
+          associate(lv=>prec%precv(level), rmp => prec%precv(level)%remap_data)
+            call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
+            call lv%ac%clone(rmp%ac_pre_remap,info)
+!!$            write(0,*) 'During first remapping desc_ac:',lv%desc_ac%is_asb(),&
+!!$                 & rmp%desc_ac_pre_remap%is_asb()
+!!$            write(0,*) ' First Doing remapping ',lnp, lnp/2
+            call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
+                 & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
+!!$        write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
+!!$             & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
+!!$            write(0,*) 'First Assignment ',size(lv%linmap%naggr),size(rmp%naggr)
+            lv%linmap%naggr(:) =  rmp%naggr(:)
+            lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
+            lv%base_a          => lv%ac
+            lv%base_desc       => lv%desc_ac
+            block
+              integer(psb_ipk_) :: meu,npu,mev,npv
+              type(psb_ctxt_type) :: ct
+              ct = lv%linmap%p_desc_U%get_ctxt()
+              call psb_info(ct,meu,npu)
+              ct = lv%linmap%p_desc_V%get_ctxt()
+              call psb_info(ct,mev,npv)
+!!$              write(0,*) 'First Check on out remapping ',i,&
+!!$                   & rmp%desc_ac_pre_remap%is_asb(),&
+!!$                   & ':',meu,npu,mev,npv
+            end block
+          end associate
+        end if
+!!$        write(0,*) 'Second Check on out remapping ',level,&
+!!$             & prec%precv(level)%remap_data%desc_ac_pre_remap%is_asb(), newsz
+      end if
+    end block
+
     if (info /= psb_success_) then 
       write(ch_err,'(a,i7)') 'Mat asb fail @ level ',i
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err=ch_err)
       goto 9999
     endif
-    if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
-
+    if (stop_hierarchy_loop) then
+      exit array_build_loop
+    else
+      if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
+    end if
   end do array_build_loop
 
-  if (newsz > 0) then
-    !
-    ! We exited early from the build loop, need to fix
-    ! the size.
-    !
-    allocate(tprecv(newsz),stat=info)
-    if (info /= psb_success_) then 
-      call psb_errpush(psb_err_from_subroutine_,name,&
-           & a_err='prec reallocation')
-      goto 9999
-    endif
-    do i=1,newsz
-      call prec%precv(i)%move_alloc(tprecv(i),info)
-    end do
-    do i=newsz+1, iszv
-      call prec%precv(i)%free(info)
-    end do
-    call move_alloc(tprecv,prec%precv) 
-    ! Ignore errors from transfer
-    info = psb_success_
-    !
-    ! Restart
-    iszv = newsz
-    ! Fix the pointers, but the level 1 should
-    ! be treated differently
-    if (.not.associated(prec%precv(1)%base_a,a)) then
-      prec%precv(1)%base_a => prec%precv(1)%ac
-    end if
-    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
-      prec%precv(i)%base_a       => prec%precv(i)%ac
-      prec%precv(i)%base_desc    => prec%precv(i)%desc_ac
-      ! 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
+!!$  write(0,*) ' Done  array_build_loop',iszv,newsz,info,psb_errstatus_fatal()
+
+  if (newsz>0) then
+!!$    do i=2,newsz
+!!$      write(0,*) me,'Newsz Out of array_build_loop ',i,':',&
+!!$           & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$    end do
+!!$    write(0,*) 'Calling set_nlevs ',newsz
+    call prec%set_nlevs(newsz)
+  else
+!!$    do i=2, iszv
+!!$      write(0,*) me,'Out of array_build_loop ',i,':',&
+!!$           & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$    end do
   end if
+  iszv = prec%get_nlevs()
+  call psb_barrier(ctxt)
 
 
-  !write(0,*) 'Should we remap? '
-  if (amg_get_do_remap().and.(np>=4)) then
-    write(0,*) 'Going for remapping '
-    if (.true.) then 
-      associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
-        call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
-        call lv%ac%clone(rmp%ac_pre_remap,info)
-        if (np >= 8) then 
-          call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
-               & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
-        else
-          call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
-               & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
-        end if
-        write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
-             & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
-        lv%linmap%naggr(:)    =  rmp%naggr(:)
-        lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
-        lv%base_a          => lv%ac
-        lv%base_desc       => lv%desc_ac
-      end associate
-    end if
-  end if
+!!$  write(0,*) ' Done  reallocating precv',iszv,newsz,info
+!!$
+!!$  do i=2, iszv
+!!$    write(0,*) me,'At end of hierarchy_bld level',i,':',&
+!!$         & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$  end do
+  call psb_barrier(ctxt)
 
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
@@ -515,8 +515,9 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   endif
 
-  iszv = size(prec%precv)
-
+  iszv = prec%get_nlevs()
+!!$  write(0,*) 'Going for cmp_complexity ',&
+!!$       & allocated(prec%precv),iszv,size(prec%precv)
   call prec%cmp_complexity()
   call prec%cmp_avg_cr()
 
@@ -656,4 +657,49 @@ contains
     return
   end subroutine restore_smoothers
 #endif
+
+  function amg_c_policy_do_remap(ctxt,level,aggsize) result(res)
+    logical :: res
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_) :: level
+    integer(psb_lpk_) :: aggsize
+    res =  amg_get_do_remap().and.(level>=2)
+!!$    res = .false.
+  end function amg_c_policy_do_remap
+
+  subroutine amg_c_hierarchy_bld_cmp_newsz(level,iszv,prevsize,&
+       & nlaggr,casize,mnratio,sizeratio,newsz)
+    implicit none 
+    integer(psb_ipk_) :: level,iszv,newsz
+    integer(psb_lpk_) :: nlaggr(:)
+    integer(psb_lpk_) :: prevsize, casize
+    real(psb_spk_)    :: mnratio, sizeratio
+    ! ==============================
+    integer(psb_lpk_) :: iaggsize
+
+    newsz    = 0 
+    iaggsize = sum(nlaggr)
+    sizeratio = prevsize
+    sizeratio = sizeratio/iaggsize
+!!$    write(0,*) 'From cmp_newsz: ',iaggsize,casize,&
+!!$         & sizeratio,mnratio, level
+
+    if (iaggsize <= casize) newsz = level      
+    if (level == iszv)      newsz = level
+
+    if (level>2) then
+      if (sizeratio < mnratio) then
+        if (sizeratio > 1) then
+          newsz = level
+        else
+          !
+          ! We are not gaining 
+          !
+          newsz = level-1
+        end if
+      end if
+    end if
+!!$    write(0,*) 'At end of cmp_newsz ',newsz
+  end subroutine amg_c_hierarchy_bld_cmp_newsz
+
 end subroutine amg_c_hierarchy_bld

amgprec/impl/amg_c_smoothers_bld.f90

@@ -136,9 +136,9 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
   !
   ! Check to ensure all procs have the same
   !
-  iszv       = size(prec%precv)
+  iszv       = prec%get_nlevs()
   call psb_bcast(ctxt,iszv)
-  if (iszv /= size(prec%precv)) then
+  if (iszv /= prec%get_nlevs()) then
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999

amgprec/impl/amg_cfile_prec_descr.f90

@@ -136,7 +136,7 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
       ! ensured by amg_precbld).
       !
       if (me == root_) then
-        nlev = size(prec%precv)
+        nlev = prec%get_nlevs()
         do ilev = 1, nlev 
           if (.not.allocated(prec%precv(ilev)%sm)) then 
             info = 3111
@@ -152,7 +152,7 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
         write(iout_,*) trim(prefix_),' Base matrix      : ',&
              & gl_nrows, gl_ncols, gl_nzeros
         write(iout_,*)
-        
+        write(iout_,*) 'At level :',1,' we have ',np,' processes'
         if (nlev == 1) then
           !
           ! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.

amgprec/impl/amg_cmlprec_aply.f90

@@ -207,6 +207,7 @@ subroutine amg_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
 
   use psb_base_mod
   use amg_base_prec_type
+  use amg_prec_mod
   use amg_c_inner_mod, amg_protect_name => amg_cmlprec_aply_vect
 
   implicit none
@@ -243,10 +244,10 @@ subroutine amg_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
 
   if (debug_level >= psb_debug_inner_) &
        & write(debug_unit,*) me,' ',trim(name),&
-       & ' Entry  ', size(p%precv)
+       & ' Entry  ', p%get_nlevs()
 
   trans_ = psb_toupper(trans)
-  nlev   = size(p%precv)
+  nlev   = p%get_nlevs()
 
   do_alloc_wrk = .not.allocated(p%precv(1)%wrk)
 
@@ -381,7 +382,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_ml')
@@ -393,39 +394,38 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
     end if
-    if (me >= 0) then
-      select case(p%precv(level)%parms%ml_cycle) 
-        
-      case(amg_no_ml_)
-        !
-        ! No preconditioning, should not really get here
-        ! 
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='amg_no_ml_ in mlprc_aply?')
-        goto 9999      
-        
-      case(amg_add_ml_)
-        
-        call amg_c_inner_add(p, level, trans, work)
-        
-      case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
-        
-        call amg_c_inner_mult(p, level, trans, work)
-        
-      case(amg_kcycle_ml_, amg_kcyclesym_ml_)
-        
-        call amg_c_inner_k_cycle(p, level, trans, work)
-        
-      case default
-        info = psb_err_from_subroutine_ai_
-        call psb_errpush(info,name,a_err='invalid ml_cycle',&
-             &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
-        goto 9999      
-        
-      end select
-      if(debug_level > 1) then
-        write(debug_unit,*) me,' End inner_ml_aply at level ',level
-      end if
+    
+    select case(p%precv(level)%parms%ml_cycle) 
+      
+    case(amg_no_ml_)
+      !
+      ! No preconditioning, should not really get here
+      ! 
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='amg_no_ml_ in mlprc_aply?')
+      goto 9999      
+      
+    case(amg_add_ml_)
+      
+      call amg_c_inner_add(p, level, trans, work)
+      
+    case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
+      
+      call amg_c_inner_mult(p, level, trans, work)
+      
+    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
+      
+      call amg_c_inner_k_cycle(p, level, trans, work)
+      
+    case default
+      info = psb_err_from_subroutine_ai_
+      call psb_errpush(info,name,a_err='invalid ml_cycle',&
+           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
+      goto 9999      
+      
+    end select
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' End inner_ml_aply at level ',level
     end if
 
     call psb_erractionrestore(err_act)
@@ -468,7 +468,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_add')
@@ -492,12 +492,13 @@ contains
          & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
          & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
          & wv => p%precv(level)%wrk%wv)
-
+      
       if (me >= 0) then 
         if (allocated(p%precv(level)%sm2a)) then
           call psb_geaxpby(cone,vx2l,czero,vy2l,base_desc,info)
           
-          sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
+          sweeps = max(p%precv(level)%parms%sweeps_pre,&
+               & p%precv(level)%parms%sweeps_post)
           do k=1, sweeps
             call p%precv(level)%sm%apply(cone,&
                  & vy2l,czero,vty,&
@@ -509,7 +510,6 @@ contains
                  & base_desc, trans,&
                  & ione,work,wv,info,init='Z')        
           end do
-          
         else
           sweeps = p%precv(level)%parms%sweeps_pre
           call p%precv(level)%sm%apply(cone,&
@@ -523,40 +523,37 @@ contains
              & a_err='Error during ADD smoother_apply')
         goto 9999
       end if
-
+      
       if (level < nlev) then
         ! Apply the restriction
         call p%precv(level+1)%map_rstr(cone,vx2l,&
              & czero,p%precv(level+1)%wrk%vx2l,&
-             & info,work=work,&
-             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+             & info,work=work,vtx=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during restriction')
           goto 9999
         end if
-
+        
         call inner_ml_aply(level+1,p,trans,work,info)
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error in recursive call')
           goto 9999
         end if
-
+        
         !
         ! Apply the prolongator
         !  
         call p%precv(level+1)%map_prol(cone,&
              & p%precv(level+1)%wrk%vy2l, cone,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work, vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
           goto 9999
         end if
-
-
+        
       end if
     end associate
     
@@ -597,7 +594,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_mult')
@@ -608,7 +605,7 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' inner_mult at level ',level
     end if
-
+!!$    write(debug_unit,*) me,' inner_mult at level (1):',level,np
     sweeps_post = p%precv(level)%parms%sweeps_post
     sweeps_pre  = p%precv(level)%parms%sweeps_pre
     pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
@@ -618,6 +615,10 @@ contains
          & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
          & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
          & wv => p%precv(level)%wrk%wv)
+!!$      write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',&
+!!$           & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv)
+      if (me >=0) then
+      
       if (level < nlev) then 
         !
         ! Apply the first smoother
@@ -625,7 +626,6 @@ contains
         !
 
         if (pre) then
-          if (me >=0) then
 !!$            write(0,*) me,'Applying smoother pre ', level
             if (trans == 'N') then 
               sweeps = p%precv(level)%parms%sweeps_pre
@@ -644,28 +644,29 @@ contains
                    & a_err='Error during PRE smoother_apply')
               goto 9999
             end if
-          end if
-        endif
+      
+          endif
         !
         ! Compute the residual for next level and call recursively
         !
         if (pre) then
-          call psb_geaxpby(cone,vx2l,&
-               & czero,vty,&
-               & base_desc,info)
-
-          if (info == psb_success_) call psb_spmm(-cone,base_a,&
-               & vy2l,cone,vty,&
-               & base_desc,info,work=work,trans=trans)
-          if (info /= psb_success_) then
-            call psb_errpush(psb_err_internal_error_,name,&
-                 & a_err='Error during residue')
-            goto 9999
-          end if
+            
+            call psb_geaxpby(cone,vx2l,&
+                 & czero,vty,&
+                 & base_desc,info)
+            
+            if (info == psb_success_) call psb_spmm(-cone,base_a,&
+                 & vy2l,cone,vty,&
+                 & base_desc,info,work=work,trans=trans)
+            if (info /= psb_success_) then
+              call psb_errpush(psb_err_internal_error_,name,&
+                   & a_err='Error during residue')
+              goto 9999
+            end if
+          
           call p%precv(level+1)%map_rstr(cone,vty,&
                & czero,p%precv(level+1)%wrk%vx2l,&
-               & info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & info,work=work,vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -675,8 +676,7 @@ contains
           ! Shortcut: just transfer x2l. 
           call p%precv(level+1)%map_rstr(cone,vx2l,&
                & czero,p%precv(level+1)%wrk%vx2l,&
-               & info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & info,work=work,vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -691,8 +691,7 @@ contains
         !  
         call p%precv(level+1)%map_prol(cone,&
              & p%precv(level+1)%wrk%vy2l,cone,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work,vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
@@ -701,17 +700,17 @@ contains
 
         if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
 
-          if (me >=0) then 
+          
             call psb_geaxpby(cone,vx2l, czero,vty,&
                  & base_desc,info)        
             if (info == psb_success_) call psb_spmm(-cone,base_a,&
                  & vy2l,cone,vty,&
                  & base_desc,info,work=work,trans=trans)
-          end if
+          
           if (info == psb_success_) &
                & call p%precv(level+1)%map_rstr(cone,vty,&
                & czero,p%precv(level+1)%wrk%vx2l,info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during W-cycle restriction')
@@ -722,8 +721,7 @@ contains
 
           if (info == psb_success_) call p%precv(level+1)%map_prol(cone, &
                & p%precv(level+1)%wrk%vy2l,cone,vy2l,&
-               & info,work=work,&
-               & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+               & info,work=work,vty=wv(1))
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -735,7 +733,7 @@ contains
 
 
         if (post) then
-          if (me >=0) then 
+          
             call psb_geaxpby(cone,vx2l,&
                  & czero,vty,&
                  & base_desc,info)
@@ -762,7 +760,7 @@ contains
                    & vty,cone,vy2l, base_desc, trans,&
                    & sweeps,work,wv,info,init='Z')
             end if
-          end if
+          
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -789,6 +787,7 @@ contains
              & a_err='Invalid LEVEL vs NLEV')
         goto 9999
       end if
+    end if
     end associate
 9998 continue
     call psb_erractionrestore(err_act)
@@ -833,7 +832,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_add')
@@ -910,7 +909,7 @@ contains
         call  p%precv(level + 1)%map_rstr(cone,vty,&
              & czero,p%precv(level + 1)%wrk%vx2l,&
              &info,work=work,&
-             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+             & vtx=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -945,8 +944,7 @@ contains
         !  
         call p%precv(level+1)%map_prol(cone,&
              & p%precv(level+1)%wrk%vy2l,cone,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work,vty=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -1007,9 +1005,6 @@ contains
   end subroutine amg_c_inner_k_cycle
   
   recursive subroutine amg_cinneritkcycle(p, level, trans, work, innersolv)
-    use psb_base_mod
-    use amg_prec_mod
-    use amg_c_inner_mod, amg_protect_name => amg_cmlprec_aply
 
     implicit none
 
@@ -1161,532 +1156,3 @@ contains
 
 end subroutine amg_cmlprec_aply_vect
 
-
-!
-! Old routine for arrays instead of psb_X_vector. To be deleted eventually.
-!
-!
-subroutine amg_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
-
-  use psb_base_mod
-  use amg_base_prec_type
-  use amg_c_inner_mod, amg_protect_name => amg_cmlprec_aply
-
-  implicit none
-
-  ! Arguments
-  type(psb_desc_type),intent(in)    :: desc_data
-  type(amg_cprec_type), intent(inout)  :: p
-  complex(psb_spk_),intent(in)         :: alpha,beta
-  complex(psb_spk_),intent(inout)      :: x(:)
-  complex(psb_spk_),intent(inout)      :: y(:)
-  character, intent(in)             :: trans
-  complex(psb_spk_),target             :: work(:)
-  integer(psb_ipk_), intent(out)              :: info
-
-  ! Local variables
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: np, me
-  integer(psb_ipk_)   :: err_act
-  integer(psb_ipk_)   :: debug_level, debug_unit, nlev,nc2l,nr2l,level
-  character(len=20)   :: name
-  character           :: trans_
-  type amg_mlwrk_type
-    complex(psb_spk_), allocatable  :: tx(:), ty(:), x2l(:), y2l(:)
-  end type amg_mlwrk_type
-  type(amg_mlwrk_type), allocatable, target  :: mlwrk(:)
-
-  name='amg_cmlprec_aply'
-  info = psb_success_
-  call psb_erractionsave(err_act)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-
-  ctxt = desc_data%get_context()
-  call psb_info(ctxt, me, np)
-
-  if (debug_level >= psb_debug_inner_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & ' Entry  ', size(p%precv)
-
-  trans_ = psb_toupper(trans)
-
-  nlev = size(p%precv)
-  allocate(mlwrk(nlev),stat=info) 
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
-    goto 9999      
-  end if
-  level = 1
-
-  do level = 1, nlev
-    call psb_geasb(mlwrk(level)%x2l,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%y2l,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%tx,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%ty,&
-         & p%precv(level)%base_desc,info)
-    if (psb_errstatus_fatal()) then 
-      nc2l = p%precv(level)%base_desc%get_local_cols()
-      info=psb_err_alloc_request_
-      call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
-           & a_err='complex(psb_spk_)')
-      goto 9999      
-    end if
-  end do
-
-  mlwrk(level)%x2l(:) = x(:) 
-  mlwrk(level)%y2l(:) = czero 
-
-  call inner_ml_aply(level,p,mlwrk,trans_,work,info)    
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,&
-         & a_err='Inner prec aply')
-    goto 9999
-  end if
-
-  call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,&
-       &   p%precv(level)%base_desc,info)
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,&
-         & a_err='Error final update')
-    goto 9999
-  end if
-
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-
-contains
-
-    !
-  !
-  ! inner_ml_aply: apply AMG at a given level.
-  ! This routine dispatches the computation according to the type
-  ! specified at the current level.
-  ! Each of the corrections will inturn call recursively this routine.
-  !
-  ! Assumptions:
-  ! On input:
-  !   mlprec_wkr(level)%vx2l   contains the input vector (RHS)
-  !   mlprec_wkr(level)%vy2l   contains the initial guess
-  !
-  ! On output:
-  !   mlprec_wkr(level)%vy2l   contains the solution
-  !
-  ! Constraints: each of the called routines must properly handle
-  ! the input/output conditions for level+1 (i.e. apply
-  ! prolongation/restriction).
-  ! Note: for historical/convenience reasons the prolongator/restrictor
-  ! between level and level+1 are stored at level+1. 
-  !
-  !
-  recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info)    
-
-    implicit none 
-
-    ! Arguments
-    integer(psb_ipk_)                           :: level 
-    type(amg_cprec_type), target, intent(inout) :: p
-    type(amg_mlwrk_type), intent(inout), target    :: mlwrk(:)
-    character, intent(in)                       :: trans
-    complex(psb_spk_),target                      :: work(:)
-    integer(psb_ipk_), intent(out)              :: info
-
-    type(psb_c_vect_type) :: res
-    type(psb_c_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_ml_aply'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_ml')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_ml_aply at level ',level
-    end if
-
-    select case(p%precv(level)%parms%ml_cycle) 
-
-    case(amg_no_ml_)
-      !
-      ! No preconditioning, should not really get here
-      ! 
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='amg_no_ml_ in mlprc_aply?')
-      goto 9999      
-
-    case(amg_add_ml_)
-
-      call amg_c_inner_add(p, mlwrk, level, trans, work)
-
-    case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_)
-
-      call amg_c_inner_mult(p, mlwrk, level, trans, work)
-      
-! !$    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
-! !$
-! !$      call amg_c_inner_k_cycle(p, mlwrk, level, trans, work)
-      
-    case default
-      info = psb_err_from_subroutine_ai_
-      call psb_errpush(info,name,a_err='invalid ml_cycle',&
-           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
-      goto 9999      
-
-    end select
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine inner_ml_aply
-
-
-  recursive subroutine amg_c_inner_add(p, mlwrk, level, trans, work)
-    use psb_base_mod
-    use amg_prec_mod
-
-    implicit none
-
-    !Input/Oputput variables
-    type(amg_cprec_type), intent(inout)  :: p
-
-    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
-    integer(psb_ipk_), intent(in) :: level
-    character, intent(in)             :: trans
-    complex(psb_spk_),target            :: work(:)
-    type(psb_c_vect_type) :: res
-    type(psb_c_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_inner_add'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_add')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_add at level ',level
-    end if
-
-    if ((level<1).or.(level>nlev)) then
-      info = psb_err_internal_error_ 
-      call psb_errpush(info,name,&
-           & a_err='Invalid LEVEL>NLEV')
-      goto 9999
-    end if
-    
-    sweeps = p%precv(level)%parms%sweeps_pre
-    call p%precv(level)%sm%apply(cone,&
-         & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,&
-         & p%precv(level)%base_desc, trans,&
-         & sweeps,work,info)
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Error during ADD smoother_apply')
-      goto 9999
-    end if
-
-    if (level < nlev) then
-      ! Apply the restriction
-      call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,&
-           & czero,mlwrk(level+1)%x2l,&
-           & info,work=work)
-      mlwrk(level+1)%y2l(:) = czero
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during restriction')
-        goto 9999
-      end if
-      
-      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error in recursive call')
-        goto 9999
-      end if
-
-      !
-      ! Apply the prolongator and add correction.
-      !  
-      call p%precv(level+1)%map_prol(cone,&
-           & mlwrk(level+1)%y2l,cone,mlwrk(level)%y2l,&
-           & info,work=work)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during prolongation')
-        goto 9999
-      end if
-
-
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine amg_c_inner_add
-
-  recursive subroutine amg_c_inner_mult(p, mlwrk, level, trans, work)
-    use psb_base_mod
-    use amg_prec_mod
-
-    implicit none
-
-    !Input/Oputput variables
-    type(amg_cprec_type), intent(inout)  :: p
-
-    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
-    integer(psb_ipk_), intent(in) :: level
-    character, intent(in)             :: trans
-    complex(psb_spk_),target            :: work(:)
-    type(psb_c_vect_type) :: res
-    type(psb_c_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_inner_mult'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_mult')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_mult at level ',level
-    end if
-
-    if ((level < nlev).or.(nlev == 1)) then
-      sweeps_post = p%precv(level)%parms%sweeps_post
-      sweeps_pre  = p%precv(level)%parms%sweeps_pre
-    else
-      sweeps_post = p%precv(level-1)%parms%sweeps_post
-      sweeps_pre  = p%precv(level-1)%parms%sweeps_pre
-    endif
-
-    pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
-    post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N'))
-
-    
-    if (level < nlev) then 
-
-      !
-      ! Apply the first smoother
-      !
-
-      if (pre) then
-        if (trans == 'N') then 
-          sweeps = p%precv(level)%parms%sweeps_pre
-          if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
-               & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Y')
-        else
-          sweeps = p%precv(level)%parms%sweeps_post
-          if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
-               & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Y')
-        end if
-        
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during PRE smoother_apply')
-          goto 9999
-        end if
-      endif
-
-      !
-      ! Compute the residual and call recursively
-      !
-      if (pre) then
-        call psb_geaxpby(cone,mlwrk(level)%x2l,&
-             & czero,mlwrk(level)%ty,&
-             & p%precv(level)%base_desc,info)
-        
-        if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,&
-             & mlwrk(level)%y2l,cone,mlwrk(level)%ty,&
-             & p%precv(level)%base_desc,info,work=work,trans=trans)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during residue')
-          goto 9999
-        end if
-        call p%precv(level+1)%map_rstr(cone,mlwrk(level)%ty,&
-             & czero,mlwrk(level+1)%x2l,info,work=work)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during restriction')
-          goto 9999
-        end if
-      else
-        ! Shortcut: just transfer x2l. 
-        call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,&
-             & czero,mlwrk(level+1)%x2l,info,work=work)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during restriction')
-          goto 9999
-        end if
-      endif
-      ! First guess is zero
-      mlwrk(level+1)%y2l(:) = czero
-      
-      
-      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      
-      if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
-        ! On second call will use output y2l as initial guess
-        if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      endif
-      
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error in recursive call')
-        goto 9999
-      end if
-      
-      
-      !
-      ! Apply the prolongator
-      !  
-      call p%precv(level+1)%map_prol(cone,mlwrk(level+1)%y2l,&
-           & cone,mlwrk(level)%y2l,info,work=work)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during prolongation')
-        goto 9999
-      end if
-      
-      !
-      ! Compute the residual
-      !
-      if (post) then
-        call psb_geaxpby(cone,mlwrk(level)%x2l,&
-             & czero,mlwrk(level)%tx,&
-             & p%precv(level)%base_desc,info)
-        call psb_spmm(-cone,p%precv(level)%base_a,mlwrk(level)%y2l,&
-             & cone,mlwrk(level)%tx,p%precv(level)%base_desc,info,&
-             & work=work,trans=trans)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during residue')
-          goto 9999
-        end if
-        !
-        ! Apply the second smoother
-        !
-        if (trans == 'N') then
-          sweeps = p%precv(level)%parms%sweeps_post
-          if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
-               & mlwrk(level)%tx,cone,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Z')
-        else 
-          sweeps = p%precv(level)%parms%sweeps_pre
-          if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
-               & mlwrk(level)%tx,cone,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Z')
-        end if
-        
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during POST smoother_apply')
-          goto 9999
-        end if
-        
-      endif            
-      
-    else if (level == nlev) then
-      
-      sweeps = p%precv(level)%parms%sweeps_pre
-      if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
-           & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,&
-           & p%precv(level)%base_desc, trans,&
-           & sweeps,work,info)
-
-    else
-
-      info = psb_err_internal_error_ 
-      call psb_errpush(info,name,&
-           & a_err='Invalid LEVEL vs NLEV')
-      goto 9999
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine amg_c_inner_mult
-    
-
-end subroutine amg_cmlprec_aply

amgprec/impl/amg_cmlprec_aply_a.f90

@@ -0,0 +1,733 @@
+!  
+!   
+!                             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 prior written permission.
+!   
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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_cmlprec_aply.f90
+!
+! Subroutine: amg_cmlprec_aply
+! Version:    real
+!
+!  Current version of this file contributed by:
+!        Ambra Abdullahi Hassan 
+!
+!
+!  This routine computes
+!  
+!                        Y = beta*Y + alpha*op(ML^(-1))*X,
+!  where 
+!  - ML is a multilevel preconditioner associated with
+!    a certain matrix A and stored in p,
+!  - op(ML^(-1)) is ML^(-1) or its transpose, according to the value of trans,
+!  - X and Y are vectors,
+!  - alpha and beta are scalars.
+!
+!  The following multilevel strategies can be applied:
+!
+!  - Additive multilevel Schwarz,
+!  - classical V-cycle,
+!  - classical W-cycle,
+!  - K-cycle both for symmetric and nonsymmetric matrices, where 2 iterations
+!    of FCG(1) or GCR, respectively, are applied at each level
+!    except the coarsest.
+!
+!  For each level we have as many submatrices as processes (except for the coarsest
+!  level where we might have a replicated index space) and each process takes care
+!  of one submatrix.
+!
+!  A multilevel preconditioner is regarded as an array of 'one-level' data structures,
+!  each containing the part of the preconditioner associated to a certain level
+!  (for more details see the description of amg_Tonelev_type in amg_prec_type.f90).
+!  For each level lev, there is a smoother stored in
+!     p%precv(lev)%sm
+!  which in turn contains a solver
+!     p$precv(lev)%sm%sv
+!  Typically the solver acts only locally, and the smoother applies any required
+!  parallel communication/action. 
+!  Each level has  a matrix A(lev), obtained by 'tranferring' the original
+!  matrix A (i.e. the matrix to be preconditioned) to the level lev, through smoothed
+!  aggregation.
+!
+!  The levels are numbered in increasing order starting from the finest one, i.e.
+!  level 1 is the finest level and A(1) is the matrix A.
+!
+!  This routine is formulated in a recursive way, so it is quite compact.
+!
+!  The V-cycle can be described as follows, where
+!  P(lev) denotes the smoothed prolongator from level lev to level
+!  lev-1, while R(lev) denotes the corresponding  restriction operator
+!  (normally its transpose) from level lev-1 to level lev.
+!  M(lev) is the smoother at the current level.
+!
+!
+!   1. Transfer the outer vector Xest to u(1) (inner X at level 1)
+!
+!   2. Invoke V-cycle(1,M,P,R,A,b,u)
+!
+!    procedure V-cycle(lev,M,P,R,A,b,u)
+!
+!      if (lev < nlev) then
+!
+!         u(lev)   = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev))
+!
+!         b(lev+1) = R(lev+1)*(b(lev)-A(lev)*u(lev))
+!
+!         u(lev+1) = V-cycle(lev+1,M,P,R,A,b,u)
+!
+!         u(lev)   = u(lev) + P(lev+1) * u(lev+1)
+!
+!         u(lev)   = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev))
+!
+!      else
+!
+!         solve  A(lev)*u(lev) = b(lev)
+!
+!      end if
+!
+!      return u(lev)
+!    end
+!
+!   3. Transfer u(1) to the external:
+!         Yext = beta*Yext + alpha*u(1)
+!
+!
+!  In the implementation, the recursive procedure is inner_ml_aply, which
+!  in turn uses amg_inner_add (for additive multilevel),
+!  amg_inner_mult (for V-cycle and W-cycle), and
+!  amg_inner_k_cycle (for symmetric and non-symmetric K-cycle).
+!  
+!  For a detailed description of the algorithms, see:
+!
+!  - B.F. Smith, P.E. Bjorstad, W.D. Gropp,
+!    Domain decomposition: parallel multilevel methods for elliptic partial
+!    differential equations, Cambridge University Press, 1996.
+!
+!  - W. L. Briggs, V. E. Henson, S. F.  McCormick,
+!    A Multigrid Tutorial, Second Edition
+!    SIAM, 2000.
+!
+!  - K. Stuben,
+!    An Introduction to Algebraic Multigrid,
+!    in A. Schuller, U. Trottenberg, C. Oosterlee, Multigrid, Academic Press, 2001.
+!
+!  - Y. Notay, P. S. Vassilevski,
+!    Recursive Krylov-based multigrid cycles
+!    Numerical Linear Algebra with Applications, 15 (5), 2008, 473--487.
+!
+!
+! Arguments:
+!   alpha      -   complex(psb_spk_), input.
+!                  The scalar alpha.
+!   p          -   type(amg_cprec_type), input.
+!                  The multilevel preconditioner data structure containing the
+!                  local part of the preconditioner to be applied.
+!      Note that nlev = size(p%precv) = number of levels.
+!      p%precv(lev)%sm        -  type(psb_cbaseprec_type)
+!                                 The pre-'smoother' for the current level
+!      p%precv(lev)%sm2       -  type(psb_cbaseprec_type)
+!                                 The post-'smoother' for the current level
+!                                 may be the same or different from %sm
+!      p%precv(lev)%ac        -  type(psb_cspmat_type) 
+!                                 The local part of the matrix A(lev).
+!      p%precv(lev)%parms     -  type(psb_sml_parms) 
+!                                 Parameters controllin the multilevel prec. 
+!      p%precv(lev)%desc_ac   -  type(psb_desc_type).
+!                                 The communication descriptor associated to the sparse
+!                                 matrix A(lev)
+!      p%precv(lev)%map       -  type(psb_inter_desc_type)
+!                                 Stores the linear operators mapping level (lev-1)
+!                                 to (lev) and vice versa. These are the restriction
+!                                 and prolongation operators described in the sequel. 
+!      p%precv(lev)%base_a    -  type(psb_cspmat_type), pointer.
+!                                 Pointer (really a pointer!) to the base matrix of
+!                                 the current level, i.e. the local part of A(lev);
+!                                 so we have a unified treatment of residuals. We
+!                                 need this to avoid passing explicitly the matrix
+!                                 A(lev) to the routine which applies the
+!                                 preconditioner.
+!      p%precv(lev)%base_desc -  type(psb_desc_type), pointer.
+!                                 Pointer to the communication descriptor associated
+!                                 to the sparse matrix pointed by base_a.  
+!                  
+!   x          -  complex(psb_spk_), dimension(:), input.
+!                 The local part of the vector X.
+!   beta       -  complex(psb_spk_), input.
+!                 The scalar beta.
+!   y          -  complex(psb_spk_), dimension(:), input/output.
+!                 The local part of the vector Y.
+!   desc_data  -  type(psb_desc_type), input.
+!                 The communication descriptor associated to the matrix to be
+!                 preconditioned.
+!   trans      -  character, optional.
+!                 If trans='N','n' then op(M^(-1)) = M^(-1);
+!                 if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)).
+!   work       -  complex(psb_spk_), dimension (:), optional, target.
+!                 Workspace. Its size must be at least 4*desc_data%get_local_cols().
+!   info       -  integer, output.
+!                 Error code.
+!
+!   Note that when the LU factorization of the matrix A(lev) is computed instead of
+!   the ILU one, by using UMFPACK or SuperLU or MUMPS, the corresponding
+!   L and U factors are stored in data structures handled
+!   by the third party software. 
+!
+
+!
+! Old routine for arrays instead of psb_X_vector. To be deleted eventually.
+!
+!
+subroutine amg_cmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info)
+
+  use psb_base_mod
+  use amg_base_prec_type
+  use amg_c_inner_mod, amg_protect_name => amg_cmlprec_aply_a
+
+  implicit none
+
+  ! Arguments
+  type(psb_desc_type),intent(in)    :: desc_data
+  type(amg_cprec_type), intent(inout)  :: p
+  complex(psb_spk_),intent(in)         :: alpha,beta
+  complex(psb_spk_),intent(inout)      :: x(:)
+  complex(psb_spk_),intent(inout)      :: y(:)
+  character, intent(in)             :: trans
+  complex(psb_spk_),target             :: work(:)
+  integer(psb_ipk_), intent(out)              :: info
+
+  ! Local variables
+  type(psb_ctxt_type) :: ctxt
+  integer(psb_ipk_)   :: np, me
+  integer(psb_ipk_)   :: err_act
+  integer(psb_ipk_)   :: debug_level, debug_unit, nlev,nc2l,nr2l,level
+  character(len=20)   :: name
+  character           :: trans_
+  type amg_mlwrk_type
+    complex(psb_spk_), allocatable  :: tx(:), ty(:), x2l(:), y2l(:)
+  end type amg_mlwrk_type
+  type(amg_mlwrk_type), allocatable, target  :: mlwrk(:)
+
+  name='amg_cmlprec_aply'
+  info = psb_success_
+  call psb_erractionsave(err_act)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  ctxt = desc_data%get_context()
+  call psb_info(ctxt, me, np)
+
+  if (debug_level >= psb_debug_inner_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & ' Entry  ', size(p%precv)
+
+  trans_ = psb_toupper(trans)
+
+  nlev = size(p%precv)
+  allocate(mlwrk(nlev),stat=info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
+    goto 9999      
+  end if
+  level = 1
+
+  do level = 1, nlev
+    call psb_geasb(mlwrk(level)%x2l,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%y2l,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%tx,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%ty,&
+         & p%precv(level)%base_desc,info)
+    if (psb_errstatus_fatal()) then 
+      nc2l = p%precv(level)%base_desc%get_local_cols()
+      info=psb_err_alloc_request_
+      call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
+           & a_err='complex(psb_spk_)')
+      goto 9999      
+    end if
+  end do
+
+  mlwrk(level)%x2l(:) = x(:) 
+  mlwrk(level)%y2l(:) = czero 
+
+  call inner_ml_aply(level,p,mlwrk,trans_,work,info)    
+
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_internal_error_,name,&
+         & a_err='Inner prec aply')
+    goto 9999
+  end if
+
+  call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,&
+       &   p%precv(level)%base_desc,info)
+
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_internal_error_,name,&
+         & a_err='Error final update')
+    goto 9999
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+
+contains
+
+    !
+  !
+  ! inner_ml_aply: apply AMG at a given level.
+  ! This routine dispatches the computation according to the type
+  ! specified at the current level.
+  ! Each of the corrections will inturn call recursively this routine.
+  !
+  ! Assumptions:
+  ! On input:
+  !   mlprec_wkr(level)%vx2l   contains the input vector (RHS)
+  !   mlprec_wkr(level)%vy2l   contains the initial guess
+  !
+  ! On output:
+  !   mlprec_wkr(level)%vy2l   contains the solution
+  !
+  ! Constraints: each of the called routines must properly handle
+  ! the input/output conditions for level+1 (i.e. apply
+  ! prolongation/restriction).
+  ! Note: for historical/convenience reasons the prolongator/restrictor
+  ! between level and level+1 are stored at level+1. 
+  !
+  !
+  recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info)    
+
+    implicit none 
+
+    ! Arguments
+    integer(psb_ipk_)                           :: level 
+    type(amg_cprec_type), target, intent(inout) :: p
+    type(amg_mlwrk_type), intent(inout), target    :: mlwrk(:)
+    character, intent(in)                       :: trans
+    complex(psb_spk_),target                      :: work(:)
+    integer(psb_ipk_), intent(out)              :: info
+
+    type(psb_c_vect_type) :: res
+    type(psb_c_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_ml_aply'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_ml')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_ml_aply at level ',level
+    end if
+
+    select case(p%precv(level)%parms%ml_cycle) 
+
+    case(amg_no_ml_)
+      !
+      ! No preconditioning, should not really get here
+      ! 
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='amg_no_ml_ in mlprc_aply?')
+      goto 9999      
+
+    case(amg_add_ml_)
+
+      call amg_c_inner_add(p, mlwrk, level, trans, work)
+
+    case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_)
+
+      call amg_c_inner_mult(p, mlwrk, level, trans, work)
+      
+! !$    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
+! !$
+! !$      call amg_c_inner_k_cycle(p, mlwrk, level, trans, work)
+      
+    case default
+      info = psb_err_from_subroutine_ai_
+      call psb_errpush(info,name,a_err='invalid ml_cycle',&
+           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
+      goto 9999      
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine inner_ml_aply
+
+  recursive subroutine amg_c_inner_add(p, mlwrk, level, trans, work)
+    use psb_base_mod
+    use amg_prec_mod
+
+    implicit none
+
+    !Input/Oputput variables
+    type(amg_cprec_type), intent(inout)  :: p
+
+    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
+    integer(psb_ipk_), intent(in) :: level
+    character, intent(in)             :: trans
+    complex(psb_spk_),target            :: work(:)
+    type(psb_c_vect_type) :: res
+    type(psb_c_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_inner_add'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_add')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_add at level ',level
+    end if
+
+    if ((level<1).or.(level>nlev)) then
+      info = psb_err_internal_error_ 
+      call psb_errpush(info,name,&
+           & a_err='Invalid LEVEL>NLEV')
+      goto 9999
+    end if
+    
+    sweeps = p%precv(level)%parms%sweeps_pre
+    call p%precv(level)%sm%apply(cone,&
+         & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,&
+         & p%precv(level)%base_desc, trans,&
+         & sweeps,work,info)
+    if (info /= psb_success_) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='Error during ADD smoother_apply')
+      goto 9999
+    end if
+
+    if (level < nlev) then
+      ! Apply the restriction
+      call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,&
+           & czero,mlwrk(level+1)%x2l,&
+           & info,work=work)
+      mlwrk(level+1)%y2l(:) = czero
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during restriction')
+        goto 9999
+      end if
+      
+      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in recursive call')
+        goto 9999
+      end if
+
+      !
+      ! Apply the prolongator and add correction.
+      !  
+      call p%precv(level+1)%map_prol(cone,&
+           & mlwrk(level+1)%y2l,cone,mlwrk(level)%y2l,&
+           & info,work=work)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during prolongation')
+        goto 9999
+      end if
+
+
+    end if
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine amg_c_inner_add
+
+  recursive subroutine amg_c_inner_mult(p, mlwrk, level, trans, work)
+    use psb_base_mod
+    use amg_prec_mod
+
+    implicit none
+
+    !Input/Oputput variables
+    type(amg_cprec_type), intent(inout)  :: p
+
+    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
+    integer(psb_ipk_), intent(in) :: level
+    character, intent(in)             :: trans
+    complex(psb_spk_),target            :: work(:)
+    type(psb_c_vect_type) :: res
+    type(psb_c_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_inner_mult'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_mult')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_mult at level ',level
+    end if
+
+    if ((level < nlev).or.(nlev == 1)) then
+      sweeps_post = p%precv(level)%parms%sweeps_post
+      sweeps_pre  = p%precv(level)%parms%sweeps_pre
+    else
+      sweeps_post = p%precv(level-1)%parms%sweeps_post
+      sweeps_pre  = p%precv(level-1)%parms%sweeps_pre
+    endif
+
+    pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
+    post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N'))
+
+    
+    if (level < nlev) then 
+
+      !
+      ! Apply the first smoother
+      !
+
+      if (pre) then
+        if (trans == 'N') then 
+          sweeps = p%precv(level)%parms%sweeps_pre
+          if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
+               & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Y')
+        else
+          sweeps = p%precv(level)%parms%sweeps_post
+          if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
+               & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Y')
+        end if
+        
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during PRE smoother_apply')
+          goto 9999
+        end if
+      endif
+
+      !
+      ! Compute the residual and call recursively
+      !
+      if (pre) then
+        call psb_geaxpby(cone,mlwrk(level)%x2l,&
+             & czero,mlwrk(level)%ty,&
+             & p%precv(level)%base_desc,info)
+        
+        if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,&
+             & mlwrk(level)%y2l,cone,mlwrk(level)%ty,&
+             & p%precv(level)%base_desc,info,work=work,trans=trans)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during residue')
+          goto 9999
+        end if
+        call p%precv(level+1)%map_rstr(cone,mlwrk(level)%ty,&
+             & czero,mlwrk(level+1)%x2l,info,work=work)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during restriction')
+          goto 9999
+        end if
+      else
+        ! Shortcut: just transfer x2l. 
+        call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,&
+             & czero,mlwrk(level+1)%x2l,info,work=work)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during restriction')
+          goto 9999
+        end if
+      endif
+      ! First guess is zero
+      mlwrk(level+1)%y2l(:) = czero
+      
+      
+      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      
+      if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
+        ! On second call will use output y2l as initial guess
+        if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      endif
+      
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in recursive call')
+        goto 9999
+      end if
+      
+      
+      !
+      ! Apply the prolongator
+      !  
+      call p%precv(level+1)%map_prol(cone,mlwrk(level+1)%y2l,&
+           & cone,mlwrk(level)%y2l,info,work=work)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during prolongation')
+        goto 9999
+      end if
+      
+      !
+      ! Compute the residual
+      !
+      if (post) then
+        call psb_geaxpby(cone,mlwrk(level)%x2l,&
+             & czero,mlwrk(level)%tx,&
+             & p%precv(level)%base_desc,info)
+        call psb_spmm(-cone,p%precv(level)%base_a,mlwrk(level)%y2l,&
+             & cone,mlwrk(level)%tx,p%precv(level)%base_desc,info,&
+             & work=work,trans=trans)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during residue')
+          goto 9999
+        end if
+        !
+        ! Apply the second smoother
+        !
+        if (trans == 'N') then
+          sweeps = p%precv(level)%parms%sweeps_post
+          if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
+               & mlwrk(level)%tx,cone,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Z')
+        else 
+          sweeps = p%precv(level)%parms%sweeps_pre
+          if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
+               & mlwrk(level)%tx,cone,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Z')
+        end if
+        
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during POST smoother_apply')
+          goto 9999
+        end if
+        
+      endif            
+      
+    else if (level == nlev) then
+      
+      sweeps = p%precv(level)%parms%sweeps_pre
+      if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
+           & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,&
+           & p%precv(level)%base_desc, trans,&
+           & sweeps,work,info)
+
+    else
+
+      info = psb_err_internal_error_ 
+      call psb_errpush(info,name,&
+           & a_err='Invalid LEVEL vs NLEV')
+      goto 9999
+    end if
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine amg_c_inner_mult
+    
+
+end subroutine amg_cmlprec_aply_a

amgprec/impl/amg_cprecinit.F90

@@ -214,9 +214,7 @@ subroutine amg_cprecinit(ctxt,prec,ptype,info)
     allocate(amg_c_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
     call prec%precv(ilev_)%default()
 
-
   case ('ML')
-
     nlev_ = prec%ag_data%max_levs
     ilev_ = 1
     allocate(prec%precv(nlev_),stat=info)
@@ -228,6 +226,8 @@ subroutine amg_cprecinit(ctxt,prec,ptype,info)
     do ilev_ = 1, nlev_
       call prec%precv(ilev_)%default()
     end do
+    call prec%set_nlevs(nlev_) 
+
     call prec%set('ML_CYCLE','VCYCLE',info)
     call prec%set('SMOOTHER_TYPE','FBGS',info)
 #if  defined(AMG_HAVE_MUMPS)
@@ -241,7 +241,6 @@ subroutine amg_cprecinit(ctxt,prec,ptype,info)
     write(psb_err_unit,*) name,&
          &': Warning: Unknown preconditioner type request "',ptype,'"'
     info = psb_err_pivot_too_small_
-
   end select
 
   call psb_erractionrestore(err_act)

amgprec/impl/amg_d_hierarchy_bld.F90

@@ -64,11 +64,9 @@
 !               Error code.              
 !  
 subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
-
   use psb_base_mod
   use amg_d_inner_mod
   use amg_d_prec_mod, amg_protect_name => amg_d_hierarchy_bld
-
   Implicit None
 
   ! Arguments
@@ -82,7 +80,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: me,np
   integer(psb_ipk_)   :: err,i,k, err_act, iszv, newsz,&
-       & nplevs, mxplevs
+       & nplevs, mxplevs, level
   integer(psb_lpk_) :: iaggsize, casize, mncsize, mncszpp
   real(psb_dpk_)     :: mnaggratio, sizeratio, athresh, aomega
   class(amg_d_base_smoother_type), allocatable :: coarse_sm, med_sm, &
@@ -98,6 +96,9 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
   character(len=40)  :: ch_err
   integer(psb_ipk_), save  :: idx_bldtp=-1, idx_matasb=-1
   logical, parameter :: do_timings=.false.
+  logical             :: stop_hierarchy_loop
+  type(psb_ctxt_type) :: lctxt
+  integer(psb_ipk_)   :: lme,lnp
 
   info=psb_success_
   err=0
@@ -130,7 +131,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
   end if
   cpymat_ = .false.
   if (present(cpymat)) cpymat_ = cpymat
-  
+
   !
   ! Check to ensure all procs have the same 
   !   
@@ -139,7 +140,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
   mnaggratio = prec%ag_data%min_cr_ratio
   mncsize    = prec%ag_data%min_coarse_size
   mncszpp    = prec%ag_data%min_coarse_size_per_process
-  iszv       = size(prec%precv)
+  iszv       = prec%get_nlevs()
   call psb_bcast(ctxt,iszv)
   call psb_bcast(ctxt,mncsize)
   call psb_bcast(ctxt,mncszpp)
@@ -165,7 +166,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
     call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
     goto 9999
   end if
-  if (iszv /= size(prec%precv)) then 
+  if (iszv /= prec%get_nlevs()) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999
@@ -180,6 +181,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
     call psb_errpush(info,name,a_err=ch_err)
     goto 9999
   endif
+
   if (iszv == 1) then
     !
     ! This is OK, since it may be called by the user even if there
@@ -227,7 +229,6 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
     casize = mncsize
   end if
   prec%ag_data%target_coarse_size = casize
-  
   nplevs = max(itwo,mxplevs)
 
   !
@@ -240,7 +241,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   end if
   !
-  ! First set desired number of levels
+  ! First set desired number of levels if different from default. 
   !
   if (iszv /= nplevs) then
     allocate(tprecv(nplevs),stat=info)
@@ -286,7 +287,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
       call prec%precv(i)%free(info)
     end do
     call move_alloc(tprecv,prec%precv)
-    iszv = size(prec%precv)
+    call prec%set_nlevs(nplevs)
+    iszv = prec%get_nlevs()
   end if
 
   !
@@ -301,15 +303,24 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
   end if
   call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
   prec%precv(1)%base_desc => prec%precv(1)%desc_ac
-  
+
+  !
+  ! Main build loop
+  !   
   newsz = 0
+  stop_hierarchy_loop = .false. 
   array_build_loop: do i=2, iszv
     !
     ! Check on the iprcparm contents: they should be the same
     ! on all processes.
     !
     call psb_bcast(ctxt,prec%precv(i)%parms)
-
+    !
+    ! Get current context: might have performed remapping
+    ! 
+    lctxt = prec%precv(i-1)%base_desc%get_ctxt()
+    call psb_info(lctxt,lme,lnp)
+!!$    write(0,*) 'Check at level',i,lme,lnp
     !
     ! Sanity checks on the parameters
     !
@@ -325,8 +336,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
          & write(debug_unit,*) me,' ',trim(name),&
          & 'Calling mlprcbld at level  ',i
     !
-    ! Build the mapping between levels i-1 and i and the matrix
-    ! at level i
+    ! Build the tentative mapping between levels i-1 and i
+    ! and the matrix at level i
     !
     if (do_timings) call psb_tic(idx_bldtp)
     if (info == psb_success_)&
@@ -348,47 +359,26 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
     ! Save op_prol just in case
     !
     call op_prol%clone(prec%precv(i)%tprol,info)
+
     !
     ! Check for early termination of aggregation loop. 
-    !      
-    iaggsize = sum(nlaggr)
-
-    sizeratio = iaggsize
-    if (i==2) then 
-      sizeratio = desc_a%get_global_rows()/sizeratio
+    !
+    if (i == 2) then 
+      call amg_d_hierarchy_bld_cmp_newsz(i,iszv,&
+           & desc_a%get_global_rows(),&
+           & nlaggr,casize,mnaggratio,sizeratio,newsz)
     else
-      sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
+      call amg_d_hierarchy_bld_cmp_newsz(i,iszv,&
+           & sum(prec%precv(i-1)%linmap%naggr),&
+           & nlaggr,casize,mnaggratio,sizeratio,newsz)
     end if
     prec%precv(i)%szratio = sizeratio
-
-    if (iaggsize <= casize) newsz = i      
-    if (i == iszv)          newsz = i
-
-    if (i>2) then
-      if (sizeratio < mnaggratio) then
-        !
-        ! We are not gaining 
-        !
-        newsz = i-1
-      end if
-
-      if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then 
-        newsz=i-1
-        if (me == 0) then 
-          write(debug_unit,*) trim(name),&
-               &': Warning: aggregates from level ',&
-               & newsz
-          write(debug_unit,*) trim(name),&
-               &':                       to level ',&
-               & iszv,' coincide.'
-          write(debug_unit,*) trim(name),&
-               &': Number of levels actually used :',newsz
-          write(debug_unit,*)
-        end if
-      end if
-    end if
     call psb_bcast(ctxt,newsz)
 
+    !
+    ! Handle reallocation, if needed, and then mat_asb to polish off the
+    ! construction
+    ! 
     if (newsz > 0) then
       !
       ! This is awkward, we are saving the aggregation parms, for the sake
@@ -422,92 +412,102 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
              & a_err=ch_err)
         goto 9999
       endif
-      exit array_build_loop
+!!$      write(0,*) ' Early exit  of array_build_loop',i,iszv,info,&
+      level = newsz
+      stop_hierarchy_loop = .true. 
     else
-      if (do_timings) call psb_tic(idx_matasb)            
+      if (do_timings) call psb_tic(idx_matasb)
       if (info == psb_success_) call prec%precv(i)%mat_asb(&
            & prec%precv(i-1)%base_a,prec%precv(i-1)%base_desc,&
            & ilaggr,nlaggr,op_prol,info)
       if (do_timings) call psb_toc(idx_matasb)      
+      level = i
     end if
+
+    !
+    ! Do we want to remap onto a smaller subset of processes?
+    ! Will need a more sophisticated policy
+    !
+    block
+      type(psb_ctxt_type) :: lctxt
+      integer(psb_ipk_)   :: lme,lnp
+      lctxt = prec%precv(level)%desc_ac%get_ctxt()
+      call psb_info(lctxt,lme,lnp)
+      if (amg_d_policy_do_remap(lctxt,level,sum(nlaggr))) then 
+!!$        write(0,*) ' Context on remapping ',lme,lnp
+        if ((lme >=0).and.(lnp>=2)) then 
+          associate(lv=>prec%precv(level), rmp => prec%precv(level)%remap_data)
+            call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
+            call lv%ac%clone(rmp%ac_pre_remap,info)
+!!$            write(0,*) 'During first remapping desc_ac:',lv%desc_ac%is_asb(),&
+!!$                 & rmp%desc_ac_pre_remap%is_asb()
+!!$            write(0,*) ' First Doing remapping ',lnp, lnp/2
+            call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
+                 & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
+!!$        write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
+!!$             & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
+!!$            write(0,*) 'First Assignment ',size(lv%linmap%naggr),size(rmp%naggr)
+            lv%linmap%naggr(:) =  rmp%naggr(:)
+            lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
+            lv%base_a          => lv%ac
+            lv%base_desc       => lv%desc_ac
+            block
+              integer(psb_ipk_) :: meu,npu,mev,npv
+              type(psb_ctxt_type) :: ct
+              ct = lv%linmap%p_desc_U%get_ctxt()
+              call psb_info(ct,meu,npu)
+              ct = lv%linmap%p_desc_V%get_ctxt()
+              call psb_info(ct,mev,npv)
+!!$              write(0,*) 'First Check on out remapping ',i,&
+!!$                   & rmp%desc_ac_pre_remap%is_asb(),&
+!!$                   & ':',meu,npu,mev,npv
+            end block
+          end associate
+        end if
+!!$        write(0,*) 'Second Check on out remapping ',level,&
+!!$             & prec%precv(level)%remap_data%desc_ac_pre_remap%is_asb(), newsz
+      end if
+    end block
+
     if (info /= psb_success_) then 
       write(ch_err,'(a,i7)') 'Mat asb fail @ level ',i
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err=ch_err)
       goto 9999
     endif
-    if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
-
+    if (stop_hierarchy_loop) then
+      exit array_build_loop
+    else
+      if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
+    end if
   end do array_build_loop
 
-  if (newsz > 0) then
-    !
-    ! We exited early from the build loop, need to fix
-    ! the size.
-    !
-    allocate(tprecv(newsz),stat=info)
-    if (info /= psb_success_) then 
-      call psb_errpush(psb_err_from_subroutine_,name,&
-           & a_err='prec reallocation')
-      goto 9999
-    endif
-    do i=1,newsz
-      call prec%precv(i)%move_alloc(tprecv(i),info)
-    end do
-    do i=newsz+1, iszv
-      call prec%precv(i)%free(info)
-    end do
-    call move_alloc(tprecv,prec%precv) 
-    ! Ignore errors from transfer
-    info = psb_success_
-    !
-    ! Restart
-    iszv = newsz
-    ! Fix the pointers, but the level 1 should
-    ! be treated differently
-    if (.not.associated(prec%precv(1)%base_a,a)) then
-      prec%precv(1)%base_a => prec%precv(1)%ac
-    end if
-    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
-      prec%precv(i)%base_a       => prec%precv(i)%ac
-      prec%precv(i)%base_desc    => prec%precv(i)%desc_ac
-      ! 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
+!!$  write(0,*) ' Done  array_build_loop',iszv,newsz,info,psb_errstatus_fatal()
+
+  if (newsz>0) then
+!!$    do i=2,newsz
+!!$      write(0,*) me,'Newsz Out of array_build_loop ',i,':',&
+!!$           & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$    end do
+!!$    write(0,*) 'Calling set_nlevs ',newsz
+    call prec%set_nlevs(newsz)
+  else
+!!$    do i=2, iszv
+!!$      write(0,*) me,'Out of array_build_loop ',i,':',&
+!!$           & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$    end do
   end if
+  iszv = prec%get_nlevs()
+  call psb_barrier(ctxt)
 
 
-  !write(0,*) 'Should we remap? '
-  if (amg_get_do_remap().and.(np>=4)) then
-    write(0,*) 'Going for remapping '
-    if (.true.) then 
-      associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
-        call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
-        call lv%ac%clone(rmp%ac_pre_remap,info)
-        if (np >= 8) then 
-          call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
-               & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
-        else
-          call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
-               & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
-        end if
-        write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
-             & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
-        lv%linmap%naggr(:)    =  rmp%naggr(:)
-        lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
-        lv%base_a          => lv%ac
-        lv%base_desc       => lv%desc_ac
-      end associate
-    end if
-  end if
+!!$  write(0,*) ' Done  reallocating precv',iszv,newsz,info
+!!$
+!!$  do i=2, iszv
+!!$    write(0,*) me,'At end of hierarchy_bld level',i,':',&
+!!$         & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$  end do
+  call psb_barrier(ctxt)
 
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
@@ -515,8 +515,9 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   endif
 
-  iszv = size(prec%precv)
-
+  iszv = prec%get_nlevs()
+!!$  write(0,*) 'Going for cmp_complexity ',&
+!!$       & allocated(prec%precv),iszv,size(prec%precv)
   call prec%cmp_complexity()
   call prec%cmp_avg_cr()
 
@@ -656,4 +657,49 @@ contains
     return
   end subroutine restore_smoothers
 #endif
+
+  function amg_d_policy_do_remap(ctxt,level,aggsize) result(res)
+    logical :: res
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_) :: level
+    integer(psb_lpk_) :: aggsize
+    res =  amg_get_do_remap().and.(level>=2)
+!!$    res = .false.
+  end function amg_d_policy_do_remap
+
+  subroutine amg_d_hierarchy_bld_cmp_newsz(level,iszv,prevsize,&
+       & nlaggr,casize,mnratio,sizeratio,newsz)
+    implicit none 
+    integer(psb_ipk_) :: level,iszv,newsz
+    integer(psb_lpk_) :: nlaggr(:)
+    integer(psb_lpk_) :: prevsize, casize
+    real(psb_dpk_)    :: mnratio, sizeratio
+    ! ==============================
+    integer(psb_lpk_) :: iaggsize
+
+    newsz    = 0 
+    iaggsize = sum(nlaggr)
+    sizeratio = prevsize
+    sizeratio = sizeratio/iaggsize
+!!$    write(0,*) 'From cmp_newsz: ',iaggsize,casize,&
+!!$         & sizeratio,mnratio, level
+
+    if (iaggsize <= casize) newsz = level      
+    if (level == iszv)      newsz = level
+
+    if (level>2) then
+      if (sizeratio < mnratio) then
+        if (sizeratio > 1) then
+          newsz = level
+        else
+          !
+          ! We are not gaining 
+          !
+          newsz = level-1
+        end if
+      end if
+    end if
+!!$    write(0,*) 'At end of cmp_newsz ',newsz
+  end subroutine amg_d_hierarchy_bld_cmp_newsz
+
 end subroutine amg_d_hierarchy_bld

amgprec/impl/amg_d_smoothers_bld.f90

@@ -136,9 +136,9 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
   !
   ! Check to ensure all procs have the same
   !
-  iszv       = size(prec%precv)
+  iszv       = prec%get_nlevs()
   call psb_bcast(ctxt,iszv)
-  if (iszv /= size(prec%precv)) then
+  if (iszv /= prec%get_nlevs()) then
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999

amgprec/impl/amg_dfile_prec_descr.f90

@@ -136,7 +136,7 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
       ! ensured by amg_precbld).
       !
       if (me == root_) then
-        nlev = size(prec%precv)
+        nlev = prec%get_nlevs()
         do ilev = 1, nlev 
           if (.not.allocated(prec%precv(ilev)%sm)) then 
             info = 3111
@@ -152,7 +152,7 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
         write(iout_,*) trim(prefix_),' Base matrix      : ',&
              & gl_nrows, gl_ncols, gl_nzeros
         write(iout_,*)
-        
+        write(iout_,*) 'At level :',1,' we have ',np,' processes'
         if (nlev == 1) then
           !
           ! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.

amgprec/impl/amg_dmlprec_aply.f90

@@ -207,6 +207,7 @@ subroutine amg_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
 
   use psb_base_mod
   use amg_base_prec_type
+  use amg_prec_mod
   use amg_d_inner_mod, amg_protect_name => amg_dmlprec_aply_vect
 
   implicit none
@@ -243,10 +244,10 @@ subroutine amg_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
 
   if (debug_level >= psb_debug_inner_) &
        & write(debug_unit,*) me,' ',trim(name),&
-       & ' Entry  ', size(p%precv)
+       & ' Entry  ', p%get_nlevs()
 
   trans_ = psb_toupper(trans)
-  nlev   = size(p%precv)
+  nlev   = p%get_nlevs()
 
   do_alloc_wrk = .not.allocated(p%precv(1)%wrk)
 
@@ -381,7 +382,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_ml')
@@ -393,39 +394,38 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
     end if
-    if (me >= 0) then
-      select case(p%precv(level)%parms%ml_cycle) 
-        
-      case(amg_no_ml_)
-        !
-        ! No preconditioning, should not really get here
-        ! 
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='amg_no_ml_ in mlprc_aply?')
-        goto 9999      
-        
-      case(amg_add_ml_)
-        
-        call amg_d_inner_add(p, level, trans, work)
-        
-      case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
-        
-        call amg_d_inner_mult(p, level, trans, work)
-        
-      case(amg_kcycle_ml_, amg_kcyclesym_ml_)
-        
-        call amg_d_inner_k_cycle(p, level, trans, work)
-        
-      case default
-        info = psb_err_from_subroutine_ai_
-        call psb_errpush(info,name,a_err='invalid ml_cycle',&
-             &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
-        goto 9999      
-        
-      end select
-      if(debug_level > 1) then
-        write(debug_unit,*) me,' End inner_ml_aply at level ',level
-      end if
+    
+    select case(p%precv(level)%parms%ml_cycle) 
+      
+    case(amg_no_ml_)
+      !
+      ! No preconditioning, should not really get here
+      ! 
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='amg_no_ml_ in mlprc_aply?')
+      goto 9999      
+      
+    case(amg_add_ml_)
+      
+      call amg_d_inner_add(p, level, trans, work)
+      
+    case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
+      
+      call amg_d_inner_mult(p, level, trans, work)
+      
+    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
+      
+      call amg_d_inner_k_cycle(p, level, trans, work)
+      
+    case default
+      info = psb_err_from_subroutine_ai_
+      call psb_errpush(info,name,a_err='invalid ml_cycle',&
+           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
+      goto 9999      
+      
+    end select
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' End inner_ml_aply at level ',level
     end if
 
     call psb_erractionrestore(err_act)
@@ -468,7 +468,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_add')
@@ -492,12 +492,13 @@ contains
          & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
          & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
          & wv => p%precv(level)%wrk%wv)
-
+      
       if (me >= 0) then 
         if (allocated(p%precv(level)%sm2a)) then
           call psb_geaxpby(done,vx2l,dzero,vy2l,base_desc,info)
           
-          sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
+          sweeps = max(p%precv(level)%parms%sweeps_pre,&
+               & p%precv(level)%parms%sweeps_post)
           do k=1, sweeps
             call p%precv(level)%sm%apply(done,&
                  & vy2l,dzero,vty,&
@@ -509,7 +510,6 @@ contains
                  & base_desc, trans,&
                  & ione,work,wv,info,init='Z')        
           end do
-          
         else
           sweeps = p%precv(level)%parms%sweeps_pre
           call p%precv(level)%sm%apply(done,&
@@ -523,40 +523,37 @@ contains
              & a_err='Error during ADD smoother_apply')
         goto 9999
       end if
-
+      
       if (level < nlev) then
         ! Apply the restriction
         call p%precv(level+1)%map_rstr(done,vx2l,&
              & dzero,p%precv(level+1)%wrk%vx2l,&
-             & info,work=work,&
-             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+             & info,work=work,vtx=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during restriction')
           goto 9999
         end if
-
+        
         call inner_ml_aply(level+1,p,trans,work,info)
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error in recursive call')
           goto 9999
         end if
-
+        
         !
         ! Apply the prolongator
         !  
         call p%precv(level+1)%map_prol(done,&
              & p%precv(level+1)%wrk%vy2l, done,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work, vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
           goto 9999
         end if
-
-
+        
       end if
     end associate
     
@@ -597,7 +594,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_mult')
@@ -608,7 +605,7 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' inner_mult at level ',level
     end if
-
+!!$    write(debug_unit,*) me,' inner_mult at level (1):',level,np
     sweeps_post = p%precv(level)%parms%sweeps_post
     sweeps_pre  = p%precv(level)%parms%sweeps_pre
     pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
@@ -618,6 +615,10 @@ contains
          & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
          & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
          & wv => p%precv(level)%wrk%wv)
+!!$      write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',&
+!!$           & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv)
+      if (me >=0) then
+      
       if (level < nlev) then 
         !
         ! Apply the first smoother
@@ -625,7 +626,6 @@ contains
         !
 
         if (pre) then
-          if (me >=0) then
 !!$            write(0,*) me,'Applying smoother pre ', level
             if (trans == 'N') then 
               sweeps = p%precv(level)%parms%sweeps_pre
@@ -644,28 +644,29 @@ contains
                    & a_err='Error during PRE smoother_apply')
               goto 9999
             end if
-          end if
-        endif
+      
+          endif
         !
         ! Compute the residual for next level and call recursively
         !
         if (pre) then
-          call psb_geaxpby(done,vx2l,&
-               & dzero,vty,&
-               & base_desc,info)
-
-          if (info == psb_success_) call psb_spmm(-done,base_a,&
-               & vy2l,done,vty,&
-               & base_desc,info,work=work,trans=trans)
-          if (info /= psb_success_) then
-            call psb_errpush(psb_err_internal_error_,name,&
-                 & a_err='Error during residue')
-            goto 9999
-          end if
+            
+            call psb_geaxpby(done,vx2l,&
+                 & dzero,vty,&
+                 & base_desc,info)
+            
+            if (info == psb_success_) call psb_spmm(-done,base_a,&
+                 & vy2l,done,vty,&
+                 & base_desc,info,work=work,trans=trans)
+            if (info /= psb_success_) then
+              call psb_errpush(psb_err_internal_error_,name,&
+                   & a_err='Error during residue')
+              goto 9999
+            end if
+          
           call p%precv(level+1)%map_rstr(done,vty,&
                & dzero,p%precv(level+1)%wrk%vx2l,&
-               & info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & info,work=work,vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -675,8 +676,7 @@ contains
           ! Shortcut: just transfer x2l. 
           call p%precv(level+1)%map_rstr(done,vx2l,&
                & dzero,p%precv(level+1)%wrk%vx2l,&
-               & info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & info,work=work,vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -691,8 +691,7 @@ contains
         !  
         call p%precv(level+1)%map_prol(done,&
              & p%precv(level+1)%wrk%vy2l,done,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work,vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
@@ -701,17 +700,17 @@ contains
 
         if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
 
-          if (me >=0) then 
+          
             call psb_geaxpby(done,vx2l, dzero,vty,&
                  & base_desc,info)        
             if (info == psb_success_) call psb_spmm(-done,base_a,&
                  & vy2l,done,vty,&
                  & base_desc,info,work=work,trans=trans)
-          end if
+          
           if (info == psb_success_) &
                & call p%precv(level+1)%map_rstr(done,vty,&
                & dzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during W-cycle restriction')
@@ -722,8 +721,7 @@ contains
 
           if (info == psb_success_) call p%precv(level+1)%map_prol(done, &
                & p%precv(level+1)%wrk%vy2l,done,vy2l,&
-               & info,work=work,&
-               & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+               & info,work=work,vty=wv(1))
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -735,7 +733,7 @@ contains
 
 
         if (post) then
-          if (me >=0) then 
+          
             call psb_geaxpby(done,vx2l,&
                  & dzero,vty,&
                  & base_desc,info)
@@ -762,7 +760,7 @@ contains
                    & vty,done,vy2l, base_desc, trans,&
                    & sweeps,work,wv,info,init='Z')
             end if
-          end if
+          
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -789,6 +787,7 @@ contains
              & a_err='Invalid LEVEL vs NLEV')
         goto 9999
       end if
+    end if
     end associate
 9998 continue
     call psb_erractionrestore(err_act)
@@ -833,7 +832,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_add')
@@ -910,7 +909,7 @@ contains
         call  p%precv(level + 1)%map_rstr(done,vty,&
              & dzero,p%precv(level + 1)%wrk%vx2l,&
              &info,work=work,&
-             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+             & vtx=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -945,8 +944,7 @@ contains
         !  
         call p%precv(level+1)%map_prol(done,&
              & p%precv(level+1)%wrk%vy2l,done,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work,vty=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -1007,9 +1005,6 @@ contains
   end subroutine amg_d_inner_k_cycle
   
   recursive subroutine amg_dinneritkcycle(p, level, trans, work, innersolv)
-    use psb_base_mod
-    use amg_prec_mod
-    use amg_d_inner_mod, amg_protect_name => amg_dmlprec_aply
 
     implicit none
 
@@ -1161,532 +1156,3 @@ contains
 
 end subroutine amg_dmlprec_aply_vect
 
-
-!
-! Old routine for arrays instead of psb_X_vector. To be deleted eventually.
-!
-!
-subroutine amg_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
-
-  use psb_base_mod
-  use amg_base_prec_type
-  use amg_d_inner_mod, amg_protect_name => amg_dmlprec_aply
-
-  implicit none
-
-  ! Arguments
-  type(psb_desc_type),intent(in)    :: desc_data
-  type(amg_dprec_type), intent(inout)  :: p
-  real(psb_dpk_),intent(in)         :: alpha,beta
-  real(psb_dpk_),intent(inout)      :: x(:)
-  real(psb_dpk_),intent(inout)      :: y(:)
-  character, intent(in)             :: trans
-  real(psb_dpk_),target             :: work(:)
-  integer(psb_ipk_), intent(out)              :: info
-
-  ! Local variables
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: np, me
-  integer(psb_ipk_)   :: err_act
-  integer(psb_ipk_)   :: debug_level, debug_unit, nlev,nc2l,nr2l,level
-  character(len=20)   :: name
-  character           :: trans_
-  type amg_mlwrk_type
-    real(psb_dpk_), allocatable  :: tx(:), ty(:), x2l(:), y2l(:)
-  end type amg_mlwrk_type
-  type(amg_mlwrk_type), allocatable, target  :: mlwrk(:)
-
-  name='amg_dmlprec_aply'
-  info = psb_success_
-  call psb_erractionsave(err_act)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-
-  ctxt = desc_data%get_context()
-  call psb_info(ctxt, me, np)
-
-  if (debug_level >= psb_debug_inner_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & ' Entry  ', size(p%precv)
-
-  trans_ = psb_toupper(trans)
-
-  nlev = size(p%precv)
-  allocate(mlwrk(nlev),stat=info) 
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
-    goto 9999      
-  end if
-  level = 1
-
-  do level = 1, nlev
-    call psb_geasb(mlwrk(level)%x2l,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%y2l,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%tx,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%ty,&
-         & p%precv(level)%base_desc,info)
-    if (psb_errstatus_fatal()) then 
-      nc2l = p%precv(level)%base_desc%get_local_cols()
-      info=psb_err_alloc_request_
-      call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
-           & a_err='real(psb_dpk_)')
-      goto 9999      
-    end if
-  end do
-
-  mlwrk(level)%x2l(:) = x(:) 
-  mlwrk(level)%y2l(:) = dzero 
-
-  call inner_ml_aply(level,p,mlwrk,trans_,work,info)    
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,&
-         & a_err='Inner prec aply')
-    goto 9999
-  end if
-
-  call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,&
-       &   p%precv(level)%base_desc,info)
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,&
-         & a_err='Error final update')
-    goto 9999
-  end if
-
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-
-contains
-
-    !
-  !
-  ! inner_ml_aply: apply AMG at a given level.
-  ! This routine dispatches the computation according to the type
-  ! specified at the current level.
-  ! Each of the corrections will inturn call recursively this routine.
-  !
-  ! Assumptions:
-  ! On input:
-  !   mlprec_wkr(level)%vx2l   contains the input vector (RHS)
-  !   mlprec_wkr(level)%vy2l   contains the initial guess
-  !
-  ! On output:
-  !   mlprec_wkr(level)%vy2l   contains the solution
-  !
-  ! Constraints: each of the called routines must properly handle
-  ! the input/output conditions for level+1 (i.e. apply
-  ! prolongation/restriction).
-  ! Note: for historical/convenience reasons the prolongator/restrictor
-  ! between level and level+1 are stored at level+1. 
-  !
-  !
-  recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info)    
-
-    implicit none 
-
-    ! Arguments
-    integer(psb_ipk_)                           :: level 
-    type(amg_dprec_type), target, intent(inout) :: p
-    type(amg_mlwrk_type), intent(inout), target    :: mlwrk(:)
-    character, intent(in)                       :: trans
-    real(psb_dpk_),target                      :: work(:)
-    integer(psb_ipk_), intent(out)              :: info
-
-    type(psb_d_vect_type) :: res
-    type(psb_d_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_ml_aply'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_ml')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_ml_aply at level ',level
-    end if
-
-    select case(p%precv(level)%parms%ml_cycle) 
-
-    case(amg_no_ml_)
-      !
-      ! No preconditioning, should not really get here
-      ! 
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='amg_no_ml_ in mlprc_aply?')
-      goto 9999      
-
-    case(amg_add_ml_)
-
-      call amg_d_inner_add(p, mlwrk, level, trans, work)
-
-    case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_)
-
-      call amg_d_inner_mult(p, mlwrk, level, trans, work)
-      
-! !$    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
-! !$
-! !$      call amg_d_inner_k_cycle(p, mlwrk, level, trans, work)
-      
-    case default
-      info = psb_err_from_subroutine_ai_
-      call psb_errpush(info,name,a_err='invalid ml_cycle',&
-           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
-      goto 9999      
-
-    end select
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine inner_ml_aply
-
-
-  recursive subroutine amg_d_inner_add(p, mlwrk, level, trans, work)
-    use psb_base_mod
-    use amg_prec_mod
-
-    implicit none
-
-    !Input/Oputput variables
-    type(amg_dprec_type), intent(inout)  :: p
-
-    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
-    integer(psb_ipk_), intent(in) :: level
-    character, intent(in)             :: trans
-    real(psb_dpk_),target            :: work(:)
-    type(psb_d_vect_type) :: res
-    type(psb_d_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_inner_add'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_add')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_add at level ',level
-    end if
-
-    if ((level<1).or.(level>nlev)) then
-      info = psb_err_internal_error_ 
-      call psb_errpush(info,name,&
-           & a_err='Invalid LEVEL>NLEV')
-      goto 9999
-    end if
-    
-    sweeps = p%precv(level)%parms%sweeps_pre
-    call p%precv(level)%sm%apply(done,&
-         & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,&
-         & p%precv(level)%base_desc, trans,&
-         & sweeps,work,info)
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Error during ADD smoother_apply')
-      goto 9999
-    end if
-
-    if (level < nlev) then
-      ! Apply the restriction
-      call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,&
-           & dzero,mlwrk(level+1)%x2l,&
-           & info,work=work)
-      mlwrk(level+1)%y2l(:) = dzero
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during restriction')
-        goto 9999
-      end if
-      
-      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error in recursive call')
-        goto 9999
-      end if
-
-      !
-      ! Apply the prolongator and add correction.
-      !  
-      call p%precv(level+1)%map_prol(done,&
-           & mlwrk(level+1)%y2l,done,mlwrk(level)%y2l,&
-           & info,work=work)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during prolongation')
-        goto 9999
-      end if
-
-
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine amg_d_inner_add
-
-  recursive subroutine amg_d_inner_mult(p, mlwrk, level, trans, work)
-    use psb_base_mod
-    use amg_prec_mod
-
-    implicit none
-
-    !Input/Oputput variables
-    type(amg_dprec_type), intent(inout)  :: p
-
-    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
-    integer(psb_ipk_), intent(in) :: level
-    character, intent(in)             :: trans
-    real(psb_dpk_),target            :: work(:)
-    type(psb_d_vect_type) :: res
-    type(psb_d_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_inner_mult'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_mult')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_mult at level ',level
-    end if
-
-    if ((level < nlev).or.(nlev == 1)) then
-      sweeps_post = p%precv(level)%parms%sweeps_post
-      sweeps_pre  = p%precv(level)%parms%sweeps_pre
-    else
-      sweeps_post = p%precv(level-1)%parms%sweeps_post
-      sweeps_pre  = p%precv(level-1)%parms%sweeps_pre
-    endif
-
-    pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
-    post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N'))
-
-    
-    if (level < nlev) then 
-
-      !
-      ! Apply the first smoother
-      !
-
-      if (pre) then
-        if (trans == 'N') then 
-          sweeps = p%precv(level)%parms%sweeps_pre
-          if (info == psb_success_) call p%precv(level)%sm%apply(done,&
-               & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Y')
-        else
-          sweeps = p%precv(level)%parms%sweeps_post
-          if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
-               & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Y')
-        end if
-        
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during PRE smoother_apply')
-          goto 9999
-        end if
-      endif
-
-      !
-      ! Compute the residual and call recursively
-      !
-      if (pre) then
-        call psb_geaxpby(done,mlwrk(level)%x2l,&
-             & dzero,mlwrk(level)%ty,&
-             & p%precv(level)%base_desc,info)
-        
-        if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,&
-             & mlwrk(level)%y2l,done,mlwrk(level)%ty,&
-             & p%precv(level)%base_desc,info,work=work,trans=trans)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during residue')
-          goto 9999
-        end if
-        call p%precv(level+1)%map_rstr(done,mlwrk(level)%ty,&
-             & dzero,mlwrk(level+1)%x2l,info,work=work)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during restriction')
-          goto 9999
-        end if
-      else
-        ! Shortcut: just transfer x2l. 
-        call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,&
-             & dzero,mlwrk(level+1)%x2l,info,work=work)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during restriction')
-          goto 9999
-        end if
-      endif
-      ! First guess is zero
-      mlwrk(level+1)%y2l(:) = dzero
-      
-      
-      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      
-      if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
-        ! On second call will use output y2l as initial guess
-        if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      endif
-      
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error in recursive call')
-        goto 9999
-      end if
-      
-      
-      !
-      ! Apply the prolongator
-      !  
-      call p%precv(level+1)%map_prol(done,mlwrk(level+1)%y2l,&
-           & done,mlwrk(level)%y2l,info,work=work)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during prolongation')
-        goto 9999
-      end if
-      
-      !
-      ! Compute the residual
-      !
-      if (post) then
-        call psb_geaxpby(done,mlwrk(level)%x2l,&
-             & dzero,mlwrk(level)%tx,&
-             & p%precv(level)%base_desc,info)
-        call psb_spmm(-done,p%precv(level)%base_a,mlwrk(level)%y2l,&
-             & done,mlwrk(level)%tx,p%precv(level)%base_desc,info,&
-             & work=work,trans=trans)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during residue')
-          goto 9999
-        end if
-        !
-        ! Apply the second smoother
-        !
-        if (trans == 'N') then
-          sweeps = p%precv(level)%parms%sweeps_post
-          if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
-               & mlwrk(level)%tx,done,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Z')
-        else 
-          sweeps = p%precv(level)%parms%sweeps_pre
-          if (info == psb_success_) call p%precv(level)%sm%apply(done,&
-               & mlwrk(level)%tx,done,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Z')
-        end if
-        
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during POST smoother_apply')
-          goto 9999
-        end if
-        
-      endif            
-      
-    else if (level == nlev) then
-      
-      sweeps = p%precv(level)%parms%sweeps_pre
-      if (info == psb_success_) call p%precv(level)%sm%apply(done,&
-           & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,&
-           & p%precv(level)%base_desc, trans,&
-           & sweeps,work,info)
-
-    else
-
-      info = psb_err_internal_error_ 
-      call psb_errpush(info,name,&
-           & a_err='Invalid LEVEL vs NLEV')
-      goto 9999
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine amg_d_inner_mult
-    
-
-end subroutine amg_dmlprec_aply

amgprec/impl/amg_dmlprec_aply_a.f90

@@ -0,0 +1,733 @@
+!  
+!   
+!                             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 prior written permission.
+!   
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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_dmlprec_aply.f90
+!
+! Subroutine: amg_dmlprec_aply
+! Version:    real
+!
+!  Current version of this file contributed by:
+!        Ambra Abdullahi Hassan 
+!
+!
+!  This routine computes
+!  
+!                        Y = beta*Y + alpha*op(ML^(-1))*X,
+!  where 
+!  - ML is a multilevel preconditioner associated with
+!    a certain matrix A and stored in p,
+!  - op(ML^(-1)) is ML^(-1) or its transpose, according to the value of trans,
+!  - X and Y are vectors,
+!  - alpha and beta are scalars.
+!
+!  The following multilevel strategies can be applied:
+!
+!  - Additive multilevel Schwarz,
+!  - classical V-cycle,
+!  - classical W-cycle,
+!  - K-cycle both for symmetric and nonsymmetric matrices, where 2 iterations
+!    of FCG(1) or GCR, respectively, are applied at each level
+!    except the coarsest.
+!
+!  For each level we have as many submatrices as processes (except for the coarsest
+!  level where we might have a replicated index space) and each process takes care
+!  of one submatrix.
+!
+!  A multilevel preconditioner is regarded as an array of 'one-level' data structures,
+!  each containing the part of the preconditioner associated to a certain level
+!  (for more details see the description of amg_Tonelev_type in amg_prec_type.f90).
+!  For each level lev, there is a smoother stored in
+!     p%precv(lev)%sm
+!  which in turn contains a solver
+!     p$precv(lev)%sm%sv
+!  Typically the solver acts only locally, and the smoother applies any required
+!  parallel communication/action. 
+!  Each level has  a matrix A(lev), obtained by 'tranferring' the original
+!  matrix A (i.e. the matrix to be preconditioned) to the level lev, through smoothed
+!  aggregation.
+!
+!  The levels are numbered in increasing order starting from the finest one, i.e.
+!  level 1 is the finest level and A(1) is the matrix A.
+!
+!  This routine is formulated in a recursive way, so it is quite compact.
+!
+!  The V-cycle can be described as follows, where
+!  P(lev) denotes the smoothed prolongator from level lev to level
+!  lev-1, while R(lev) denotes the corresponding  restriction operator
+!  (normally its transpose) from level lev-1 to level lev.
+!  M(lev) is the smoother at the current level.
+!
+!
+!   1. Transfer the outer vector Xest to u(1) (inner X at level 1)
+!
+!   2. Invoke V-cycle(1,M,P,R,A,b,u)
+!
+!    procedure V-cycle(lev,M,P,R,A,b,u)
+!
+!      if (lev < nlev) then
+!
+!         u(lev)   = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev))
+!
+!         b(lev+1) = R(lev+1)*(b(lev)-A(lev)*u(lev))
+!
+!         u(lev+1) = V-cycle(lev+1,M,P,R,A,b,u)
+!
+!         u(lev)   = u(lev) + P(lev+1) * u(lev+1)
+!
+!         u(lev)   = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev))
+!
+!      else
+!
+!         solve  A(lev)*u(lev) = b(lev)
+!
+!      end if
+!
+!      return u(lev)
+!    end
+!
+!   3. Transfer u(1) to the external:
+!         Yext = beta*Yext + alpha*u(1)
+!
+!
+!  In the implementation, the recursive procedure is inner_ml_aply, which
+!  in turn uses amg_inner_add (for additive multilevel),
+!  amg_inner_mult (for V-cycle and W-cycle), and
+!  amg_inner_k_cycle (for symmetric and non-symmetric K-cycle).
+!  
+!  For a detailed description of the algorithms, see:
+!
+!  - B.F. Smith, P.E. Bjorstad, W.D. Gropp,
+!    Domain decomposition: parallel multilevel methods for elliptic partial
+!    differential equations, Cambridge University Press, 1996.
+!
+!  - W. L. Briggs, V. E. Henson, S. F.  McCormick,
+!    A Multigrid Tutorial, Second Edition
+!    SIAM, 2000.
+!
+!  - K. Stuben,
+!    An Introduction to Algebraic Multigrid,
+!    in A. Schuller, U. Trottenberg, C. Oosterlee, Multigrid, Academic Press, 2001.
+!
+!  - Y. Notay, P. S. Vassilevski,
+!    Recursive Krylov-based multigrid cycles
+!    Numerical Linear Algebra with Applications, 15 (5), 2008, 473--487.
+!
+!
+! Arguments:
+!   alpha      -   real(psb_dpk_), input.
+!                  The scalar alpha.
+!   p          -   type(amg_dprec_type), input.
+!                  The multilevel preconditioner data structure containing the
+!                  local part of the preconditioner to be applied.
+!      Note that nlev = size(p%precv) = number of levels.
+!      p%precv(lev)%sm        -  type(psb_dbaseprec_type)
+!                                 The pre-'smoother' for the current level
+!      p%precv(lev)%sm2       -  type(psb_dbaseprec_type)
+!                                 The post-'smoother' for the current level
+!                                 may be the same or different from %sm
+!      p%precv(lev)%ac        -  type(psb_dspmat_type) 
+!                                 The local part of the matrix A(lev).
+!      p%precv(lev)%parms     -  type(psb_dml_parms) 
+!                                 Parameters controllin the multilevel prec. 
+!      p%precv(lev)%desc_ac   -  type(psb_desc_type).
+!                                 The communication descriptor associated to the sparse
+!                                 matrix A(lev)
+!      p%precv(lev)%map       -  type(psb_inter_desc_type)
+!                                 Stores the linear operators mapping level (lev-1)
+!                                 to (lev) and vice versa. These are the restriction
+!                                 and prolongation operators described in the sequel. 
+!      p%precv(lev)%base_a    -  type(psb_dspmat_type), pointer.
+!                                 Pointer (really a pointer!) to the base matrix of
+!                                 the current level, i.e. the local part of A(lev);
+!                                 so we have a unified treatment of residuals. We
+!                                 need this to avoid passing explicitly the matrix
+!                                 A(lev) to the routine which applies the
+!                                 preconditioner.
+!      p%precv(lev)%base_desc -  type(psb_desc_type), pointer.
+!                                 Pointer to the communication descriptor associated
+!                                 to the sparse matrix pointed by base_a.  
+!                  
+!   x          -  real(psb_dpk_), dimension(:), input.
+!                 The local part of the vector X.
+!   beta       -  real(psb_dpk_), input.
+!                 The scalar beta.
+!   y          -  real(psb_dpk_), dimension(:), input/output.
+!                 The local part of the vector Y.
+!   desc_data  -  type(psb_desc_type), input.
+!                 The communication descriptor associated to the matrix to be
+!                 preconditioned.
+!   trans      -  character, optional.
+!                 If trans='N','n' then op(M^(-1)) = M^(-1);
+!                 if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)).
+!   work       -  real(psb_dpk_), dimension (:), optional, target.
+!                 Workspace. Its size must be at least 4*desc_data%get_local_cols().
+!   info       -  integer, output.
+!                 Error code.
+!
+!   Note that when the LU factorization of the matrix A(lev) is computed instead of
+!   the ILU one, by using UMFPACK or SuperLU or MUMPS, the corresponding
+!   L and U factors are stored in data structures handled
+!   by the third party software. 
+!
+
+!
+! Old routine for arrays instead of psb_X_vector. To be deleted eventually.
+!
+!
+subroutine amg_dmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info)
+
+  use psb_base_mod
+  use amg_base_prec_type
+  use amg_d_inner_mod, amg_protect_name => amg_dmlprec_aply_a
+
+  implicit none
+
+  ! Arguments
+  type(psb_desc_type),intent(in)    :: desc_data
+  type(amg_dprec_type), intent(inout)  :: p
+  real(psb_dpk_),intent(in)         :: alpha,beta
+  real(psb_dpk_),intent(inout)      :: x(:)
+  real(psb_dpk_),intent(inout)      :: y(:)
+  character, intent(in)             :: trans
+  real(psb_dpk_),target             :: work(:)
+  integer(psb_ipk_), intent(out)              :: info
+
+  ! Local variables
+  type(psb_ctxt_type) :: ctxt
+  integer(psb_ipk_)   :: np, me
+  integer(psb_ipk_)   :: err_act
+  integer(psb_ipk_)   :: debug_level, debug_unit, nlev,nc2l,nr2l,level
+  character(len=20)   :: name
+  character           :: trans_
+  type amg_mlwrk_type
+    real(psb_dpk_), allocatable  :: tx(:), ty(:), x2l(:), y2l(:)
+  end type amg_mlwrk_type
+  type(amg_mlwrk_type), allocatable, target  :: mlwrk(:)
+
+  name='amg_dmlprec_aply'
+  info = psb_success_
+  call psb_erractionsave(err_act)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  ctxt = desc_data%get_context()
+  call psb_info(ctxt, me, np)
+
+  if (debug_level >= psb_debug_inner_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & ' Entry  ', size(p%precv)
+
+  trans_ = psb_toupper(trans)
+
+  nlev = size(p%precv)
+  allocate(mlwrk(nlev),stat=info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
+    goto 9999      
+  end if
+  level = 1
+
+  do level = 1, nlev
+    call psb_geasb(mlwrk(level)%x2l,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%y2l,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%tx,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%ty,&
+         & p%precv(level)%base_desc,info)
+    if (psb_errstatus_fatal()) then 
+      nc2l = p%precv(level)%base_desc%get_local_cols()
+      info=psb_err_alloc_request_
+      call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
+           & a_err='real(psb_dpk_)')
+      goto 9999      
+    end if
+  end do
+
+  mlwrk(level)%x2l(:) = x(:) 
+  mlwrk(level)%y2l(:) = dzero 
+
+  call inner_ml_aply(level,p,mlwrk,trans_,work,info)    
+
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_internal_error_,name,&
+         & a_err='Inner prec aply')
+    goto 9999
+  end if
+
+  call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,&
+       &   p%precv(level)%base_desc,info)
+
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_internal_error_,name,&
+         & a_err='Error final update')
+    goto 9999
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+
+contains
+
+    !
+  !
+  ! inner_ml_aply: apply AMG at a given level.
+  ! This routine dispatches the computation according to the type
+  ! specified at the current level.
+  ! Each of the corrections will inturn call recursively this routine.
+  !
+  ! Assumptions:
+  ! On input:
+  !   mlprec_wkr(level)%vx2l   contains the input vector (RHS)
+  !   mlprec_wkr(level)%vy2l   contains the initial guess
+  !
+  ! On output:
+  !   mlprec_wkr(level)%vy2l   contains the solution
+  !
+  ! Constraints: each of the called routines must properly handle
+  ! the input/output conditions for level+1 (i.e. apply
+  ! prolongation/restriction).
+  ! Note: for historical/convenience reasons the prolongator/restrictor
+  ! between level and level+1 are stored at level+1. 
+  !
+  !
+  recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info)    
+
+    implicit none 
+
+    ! Arguments
+    integer(psb_ipk_)                           :: level 
+    type(amg_dprec_type), target, intent(inout) :: p
+    type(amg_mlwrk_type), intent(inout), target    :: mlwrk(:)
+    character, intent(in)                       :: trans
+    real(psb_dpk_),target                      :: work(:)
+    integer(psb_ipk_), intent(out)              :: info
+
+    type(psb_d_vect_type) :: res
+    type(psb_d_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_ml_aply'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_ml')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_ml_aply at level ',level
+    end if
+
+    select case(p%precv(level)%parms%ml_cycle) 
+
+    case(amg_no_ml_)
+      !
+      ! No preconditioning, should not really get here
+      ! 
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='amg_no_ml_ in mlprc_aply?')
+      goto 9999      
+
+    case(amg_add_ml_)
+
+      call amg_d_inner_add(p, mlwrk, level, trans, work)
+
+    case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_)
+
+      call amg_d_inner_mult(p, mlwrk, level, trans, work)
+      
+! !$    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
+! !$
+! !$      call amg_d_inner_k_cycle(p, mlwrk, level, trans, work)
+      
+    case default
+      info = psb_err_from_subroutine_ai_
+      call psb_errpush(info,name,a_err='invalid ml_cycle',&
+           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
+      goto 9999      
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine inner_ml_aply
+
+  recursive subroutine amg_d_inner_add(p, mlwrk, level, trans, work)
+    use psb_base_mod
+    use amg_prec_mod
+
+    implicit none
+
+    !Input/Oputput variables
+    type(amg_dprec_type), intent(inout)  :: p
+
+    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
+    integer(psb_ipk_), intent(in) :: level
+    character, intent(in)             :: trans
+    real(psb_dpk_),target            :: work(:)
+    type(psb_d_vect_type) :: res
+    type(psb_d_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_inner_add'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_add')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_add at level ',level
+    end if
+
+    if ((level<1).or.(level>nlev)) then
+      info = psb_err_internal_error_ 
+      call psb_errpush(info,name,&
+           & a_err='Invalid LEVEL>NLEV')
+      goto 9999
+    end if
+    
+    sweeps = p%precv(level)%parms%sweeps_pre
+    call p%precv(level)%sm%apply(done,&
+         & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,&
+         & p%precv(level)%base_desc, trans,&
+         & sweeps,work,info)
+    if (info /= psb_success_) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='Error during ADD smoother_apply')
+      goto 9999
+    end if
+
+    if (level < nlev) then
+      ! Apply the restriction
+      call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,&
+           & dzero,mlwrk(level+1)%x2l,&
+           & info,work=work)
+      mlwrk(level+1)%y2l(:) = dzero
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during restriction')
+        goto 9999
+      end if
+      
+      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in recursive call')
+        goto 9999
+      end if
+
+      !
+      ! Apply the prolongator and add correction.
+      !  
+      call p%precv(level+1)%map_prol(done,&
+           & mlwrk(level+1)%y2l,done,mlwrk(level)%y2l,&
+           & info,work=work)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during prolongation')
+        goto 9999
+      end if
+
+
+    end if
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine amg_d_inner_add
+
+  recursive subroutine amg_d_inner_mult(p, mlwrk, level, trans, work)
+    use psb_base_mod
+    use amg_prec_mod
+
+    implicit none
+
+    !Input/Oputput variables
+    type(amg_dprec_type), intent(inout)  :: p
+
+    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
+    integer(psb_ipk_), intent(in) :: level
+    character, intent(in)             :: trans
+    real(psb_dpk_),target            :: work(:)
+    type(psb_d_vect_type) :: res
+    type(psb_d_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_inner_mult'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_mult')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_mult at level ',level
+    end if
+
+    if ((level < nlev).or.(nlev == 1)) then
+      sweeps_post = p%precv(level)%parms%sweeps_post
+      sweeps_pre  = p%precv(level)%parms%sweeps_pre
+    else
+      sweeps_post = p%precv(level-1)%parms%sweeps_post
+      sweeps_pre  = p%precv(level-1)%parms%sweeps_pre
+    endif
+
+    pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
+    post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N'))
+
+    
+    if (level < nlev) then 
+
+      !
+      ! Apply the first smoother
+      !
+
+      if (pre) then
+        if (trans == 'N') then 
+          sweeps = p%precv(level)%parms%sweeps_pre
+          if (info == psb_success_) call p%precv(level)%sm%apply(done,&
+               & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Y')
+        else
+          sweeps = p%precv(level)%parms%sweeps_post
+          if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
+               & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Y')
+        end if
+        
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during PRE smoother_apply')
+          goto 9999
+        end if
+      endif
+
+      !
+      ! Compute the residual and call recursively
+      !
+      if (pre) then
+        call psb_geaxpby(done,mlwrk(level)%x2l,&
+             & dzero,mlwrk(level)%ty,&
+             & p%precv(level)%base_desc,info)
+        
+        if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,&
+             & mlwrk(level)%y2l,done,mlwrk(level)%ty,&
+             & p%precv(level)%base_desc,info,work=work,trans=trans)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during residue')
+          goto 9999
+        end if
+        call p%precv(level+1)%map_rstr(done,mlwrk(level)%ty,&
+             & dzero,mlwrk(level+1)%x2l,info,work=work)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during restriction')
+          goto 9999
+        end if
+      else
+        ! Shortcut: just transfer x2l. 
+        call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,&
+             & dzero,mlwrk(level+1)%x2l,info,work=work)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during restriction')
+          goto 9999
+        end if
+      endif
+      ! First guess is zero
+      mlwrk(level+1)%y2l(:) = dzero
+      
+      
+      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      
+      if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
+        ! On second call will use output y2l as initial guess
+        if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      endif
+      
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in recursive call')
+        goto 9999
+      end if
+      
+      
+      !
+      ! Apply the prolongator
+      !  
+      call p%precv(level+1)%map_prol(done,mlwrk(level+1)%y2l,&
+           & done,mlwrk(level)%y2l,info,work=work)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during prolongation')
+        goto 9999
+      end if
+      
+      !
+      ! Compute the residual
+      !
+      if (post) then
+        call psb_geaxpby(done,mlwrk(level)%x2l,&
+             & dzero,mlwrk(level)%tx,&
+             & p%precv(level)%base_desc,info)
+        call psb_spmm(-done,p%precv(level)%base_a,mlwrk(level)%y2l,&
+             & done,mlwrk(level)%tx,p%precv(level)%base_desc,info,&
+             & work=work,trans=trans)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during residue')
+          goto 9999
+        end if
+        !
+        ! Apply the second smoother
+        !
+        if (trans == 'N') then
+          sweeps = p%precv(level)%parms%sweeps_post
+          if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
+               & mlwrk(level)%tx,done,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Z')
+        else 
+          sweeps = p%precv(level)%parms%sweeps_pre
+          if (info == psb_success_) call p%precv(level)%sm%apply(done,&
+               & mlwrk(level)%tx,done,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Z')
+        end if
+        
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during POST smoother_apply')
+          goto 9999
+        end if
+        
+      endif            
+      
+    else if (level == nlev) then
+      
+      sweeps = p%precv(level)%parms%sweeps_pre
+      if (info == psb_success_) call p%precv(level)%sm%apply(done,&
+           & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,&
+           & p%precv(level)%base_desc, trans,&
+           & sweeps,work,info)
+
+    else
+
+      info = psb_err_internal_error_ 
+      call psb_errpush(info,name,&
+           & a_err='Invalid LEVEL vs NLEV')
+      goto 9999
+    end if
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine amg_d_inner_mult
+    
+
+end subroutine amg_dmlprec_aply_a

amgprec/impl/amg_dprecinit.F90

@@ -226,9 +226,7 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info)
     allocate(amg_d_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
     call prec%precv(ilev_)%default()
 
-
   case ('ML')
-
     nlev_ = prec%ag_data%max_levs
     ilev_ = 1
     allocate(prec%precv(nlev_),stat=info)
@@ -240,6 +238,8 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info)
     do ilev_ = 1, nlev_
       call prec%precv(ilev_)%default()
     end do
+    call prec%set_nlevs(nlev_) 
+
     call prec%set('ML_CYCLE','VCYCLE',info)
     call prec%set('SMOOTHER_TYPE','FBGS',info)
 #if defined(AMG_HAVE_UMF)
@@ -255,7 +255,6 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info)
     write(psb_err_unit,*) name,&
          &': Warning: Unknown preconditioner type request "',ptype,'"'
     info = psb_err_pivot_too_small_
-
   end select
 
   call psb_erractionrestore(err_act)

amgprec/impl/amg_s_hierarchy_bld.F90

@@ -64,11 +64,9 @@
 !               Error code.              
 !  
 subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
-
   use psb_base_mod
   use amg_s_inner_mod
   use amg_s_prec_mod, amg_protect_name => amg_s_hierarchy_bld
-
   Implicit None
 
   ! Arguments
@@ -82,7 +80,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: me,np
   integer(psb_ipk_)   :: err,i,k, err_act, iszv, newsz,&
-       & nplevs, mxplevs
+       & nplevs, mxplevs, level
   integer(psb_lpk_) :: iaggsize, casize, mncsize, mncszpp
   real(psb_spk_)     :: mnaggratio, sizeratio, athresh, aomega
   class(amg_s_base_smoother_type), allocatable :: coarse_sm, med_sm, &
@@ -98,6 +96,9 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
   character(len=40)  :: ch_err
   integer(psb_ipk_), save  :: idx_bldtp=-1, idx_matasb=-1
   logical, parameter :: do_timings=.false.
+  logical             :: stop_hierarchy_loop
+  type(psb_ctxt_type) :: lctxt
+  integer(psb_ipk_)   :: lme,lnp
 
   info=psb_success_
   err=0
@@ -130,7 +131,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
   end if
   cpymat_ = .false.
   if (present(cpymat)) cpymat_ = cpymat
-  
+
   !
   ! Check to ensure all procs have the same 
   !   
@@ -139,7 +140,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
   mnaggratio = prec%ag_data%min_cr_ratio
   mncsize    = prec%ag_data%min_coarse_size
   mncszpp    = prec%ag_data%min_coarse_size_per_process
-  iszv       = size(prec%precv)
+  iszv       = prec%get_nlevs()
   call psb_bcast(ctxt,iszv)
   call psb_bcast(ctxt,mncsize)
   call psb_bcast(ctxt,mncszpp)
@@ -165,7 +166,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
     call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
     goto 9999
   end if
-  if (iszv /= size(prec%precv)) then 
+  if (iszv /= prec%get_nlevs()) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999
@@ -180,6 +181,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
     call psb_errpush(info,name,a_err=ch_err)
     goto 9999
   endif
+
   if (iszv == 1) then
     !
     ! This is OK, since it may be called by the user even if there
@@ -227,7 +229,6 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
     casize = mncsize
   end if
   prec%ag_data%target_coarse_size = casize
-  
   nplevs = max(itwo,mxplevs)
 
   !
@@ -240,7 +241,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   end if
   !
-  ! First set desired number of levels
+  ! First set desired number of levels if different from default. 
   !
   if (iszv /= nplevs) then
     allocate(tprecv(nplevs),stat=info)
@@ -286,7 +287,8 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
       call prec%precv(i)%free(info)
     end do
     call move_alloc(tprecv,prec%precv)
-    iszv = size(prec%precv)
+    call prec%set_nlevs(nplevs)
+    iszv = prec%get_nlevs()
   end if
 
   !
@@ -301,15 +303,24 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
   end if
   call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
   prec%precv(1)%base_desc => prec%precv(1)%desc_ac
-  
+
+  !
+  ! Main build loop
+  !   
   newsz = 0
+  stop_hierarchy_loop = .false. 
   array_build_loop: do i=2, iszv
     !
     ! Check on the iprcparm contents: they should be the same
     ! on all processes.
     !
     call psb_bcast(ctxt,prec%precv(i)%parms)
-
+    !
+    ! Get current context: might have performed remapping
+    ! 
+    lctxt = prec%precv(i-1)%base_desc%get_ctxt()
+    call psb_info(lctxt,lme,lnp)
+!!$    write(0,*) 'Check at level',i,lme,lnp
     !
     ! Sanity checks on the parameters
     !
@@ -325,8 +336,8 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
          & write(debug_unit,*) me,' ',trim(name),&
          & 'Calling mlprcbld at level  ',i
     !
-    ! Build the mapping between levels i-1 and i and the matrix
-    ! at level i
+    ! Build the tentative mapping between levels i-1 and i
+    ! and the matrix at level i
     !
     if (do_timings) call psb_tic(idx_bldtp)
     if (info == psb_success_)&
@@ -348,47 +359,26 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
     ! Save op_prol just in case
     !
     call op_prol%clone(prec%precv(i)%tprol,info)
+
     !
     ! Check for early termination of aggregation loop. 
-    !      
-    iaggsize = sum(nlaggr)
-
-    sizeratio = iaggsize
-    if (i==2) then 
-      sizeratio = desc_a%get_global_rows()/sizeratio
+    !
+    if (i == 2) then 
+      call amg_s_hierarchy_bld_cmp_newsz(i,iszv,&
+           & desc_a%get_global_rows(),&
+           & nlaggr,casize,mnaggratio,sizeratio,newsz)
     else
-      sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
+      call amg_s_hierarchy_bld_cmp_newsz(i,iszv,&
+           & sum(prec%precv(i-1)%linmap%naggr),&
+           & nlaggr,casize,mnaggratio,sizeratio,newsz)
     end if
     prec%precv(i)%szratio = sizeratio
-
-    if (iaggsize <= casize) newsz = i      
-    if (i == iszv)          newsz = i
-
-    if (i>2) then
-      if (sizeratio < mnaggratio) then
-        !
-        ! We are not gaining 
-        !
-        newsz = i-1
-      end if
-
-      if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then 
-        newsz=i-1
-        if (me == 0) then 
-          write(debug_unit,*) trim(name),&
-               &': Warning: aggregates from level ',&
-               & newsz
-          write(debug_unit,*) trim(name),&
-               &':                       to level ',&
-               & iszv,' coincide.'
-          write(debug_unit,*) trim(name),&
-               &': Number of levels actually used :',newsz
-          write(debug_unit,*)
-        end if
-      end if
-    end if
     call psb_bcast(ctxt,newsz)
 
+    !
+    ! Handle reallocation, if needed, and then mat_asb to polish off the
+    ! construction
+    ! 
     if (newsz > 0) then
       !
       ! This is awkward, we are saving the aggregation parms, for the sake
@@ -422,92 +412,102 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
              & a_err=ch_err)
         goto 9999
       endif
-      exit array_build_loop
+!!$      write(0,*) ' Early exit  of array_build_loop',i,iszv,info,&
+      level = newsz
+      stop_hierarchy_loop = .true. 
     else
-      if (do_timings) call psb_tic(idx_matasb)            
+      if (do_timings) call psb_tic(idx_matasb)
       if (info == psb_success_) call prec%precv(i)%mat_asb(&
            & prec%precv(i-1)%base_a,prec%precv(i-1)%base_desc,&
            & ilaggr,nlaggr,op_prol,info)
       if (do_timings) call psb_toc(idx_matasb)      
+      level = i
     end if
+
+    !
+    ! Do we want to remap onto a smaller subset of processes?
+    ! Will need a more sophisticated policy
+    !
+    block
+      type(psb_ctxt_type) :: lctxt
+      integer(psb_ipk_)   :: lme,lnp
+      lctxt = prec%precv(level)%desc_ac%get_ctxt()
+      call psb_info(lctxt,lme,lnp)
+      if (amg_s_policy_do_remap(lctxt,level,sum(nlaggr))) then 
+!!$        write(0,*) ' Context on remapping ',lme,lnp
+        if ((lme >=0).and.(lnp>=2)) then 
+          associate(lv=>prec%precv(level), rmp => prec%precv(level)%remap_data)
+            call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
+            call lv%ac%clone(rmp%ac_pre_remap,info)
+!!$            write(0,*) 'During first remapping desc_ac:',lv%desc_ac%is_asb(),&
+!!$                 & rmp%desc_ac_pre_remap%is_asb()
+!!$            write(0,*) ' First Doing remapping ',lnp, lnp/2
+            call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
+                 & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
+!!$        write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
+!!$             & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
+!!$            write(0,*) 'First Assignment ',size(lv%linmap%naggr),size(rmp%naggr)
+            lv%linmap%naggr(:) =  rmp%naggr(:)
+            lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
+            lv%base_a          => lv%ac
+            lv%base_desc       => lv%desc_ac
+            block
+              integer(psb_ipk_) :: meu,npu,mev,npv
+              type(psb_ctxt_type) :: ct
+              ct = lv%linmap%p_desc_U%get_ctxt()
+              call psb_info(ct,meu,npu)
+              ct = lv%linmap%p_desc_V%get_ctxt()
+              call psb_info(ct,mev,npv)
+!!$              write(0,*) 'First Check on out remapping ',i,&
+!!$                   & rmp%desc_ac_pre_remap%is_asb(),&
+!!$                   & ':',meu,npu,mev,npv
+            end block
+          end associate
+        end if
+!!$        write(0,*) 'Second Check on out remapping ',level,&
+!!$             & prec%precv(level)%remap_data%desc_ac_pre_remap%is_asb(), newsz
+      end if
+    end block
+
     if (info /= psb_success_) then 
       write(ch_err,'(a,i7)') 'Mat asb fail @ level ',i
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err=ch_err)
       goto 9999
     endif
-    if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
-
+    if (stop_hierarchy_loop) then
+      exit array_build_loop
+    else
+      if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
+    end if
   end do array_build_loop
 
-  if (newsz > 0) then
-    !
-    ! We exited early from the build loop, need to fix
-    ! the size.
-    !
-    allocate(tprecv(newsz),stat=info)
-    if (info /= psb_success_) then 
-      call psb_errpush(psb_err_from_subroutine_,name,&
-           & a_err='prec reallocation')
-      goto 9999
-    endif
-    do i=1,newsz
-      call prec%precv(i)%move_alloc(tprecv(i),info)
-    end do
-    do i=newsz+1, iszv
-      call prec%precv(i)%free(info)
-    end do
-    call move_alloc(tprecv,prec%precv) 
-    ! Ignore errors from transfer
-    info = psb_success_
-    !
-    ! Restart
-    iszv = newsz
-    ! Fix the pointers, but the level 1 should
-    ! be treated differently
-    if (.not.associated(prec%precv(1)%base_a,a)) then
-      prec%precv(1)%base_a => prec%precv(1)%ac
-    end if
-    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
-      prec%precv(i)%base_a       => prec%precv(i)%ac
-      prec%precv(i)%base_desc    => prec%precv(i)%desc_ac
-      ! 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
+!!$  write(0,*) ' Done  array_build_loop',iszv,newsz,info,psb_errstatus_fatal()
+
+  if (newsz>0) then
+!!$    do i=2,newsz
+!!$      write(0,*) me,'Newsz Out of array_build_loop ',i,':',&
+!!$           & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$    end do
+!!$    write(0,*) 'Calling set_nlevs ',newsz
+    call prec%set_nlevs(newsz)
+  else
+!!$    do i=2, iszv
+!!$      write(0,*) me,'Out of array_build_loop ',i,':',&
+!!$           & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$    end do
   end if
+  iszv = prec%get_nlevs()
+  call psb_barrier(ctxt)
 
 
-  !write(0,*) 'Should we remap? '
-  if (amg_get_do_remap().and.(np>=4)) then
-    write(0,*) 'Going for remapping '
-    if (.true.) then 
-      associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
-        call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
-        call lv%ac%clone(rmp%ac_pre_remap,info)
-        if (np >= 8) then 
-          call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
-               & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
-        else
-          call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
-               & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
-        end if
-        write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
-             & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
-        lv%linmap%naggr(:)    =  rmp%naggr(:)
-        lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
-        lv%base_a          => lv%ac
-        lv%base_desc       => lv%desc_ac
-      end associate
-    end if
-  end if
+!!$  write(0,*) ' Done  reallocating precv',iszv,newsz,info
+!!$
+!!$  do i=2, iszv
+!!$    write(0,*) me,'At end of hierarchy_bld level',i,':',&
+!!$         & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$  end do
+  call psb_barrier(ctxt)
 
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
@@ -515,8 +515,9 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   endif
 
-  iszv = size(prec%precv)
-
+  iszv = prec%get_nlevs()
+!!$  write(0,*) 'Going for cmp_complexity ',&
+!!$       & allocated(prec%precv),iszv,size(prec%precv)
   call prec%cmp_complexity()
   call prec%cmp_avg_cr()
 
@@ -656,4 +657,49 @@ contains
     return
   end subroutine restore_smoothers
 #endif
+
+  function amg_s_policy_do_remap(ctxt,level,aggsize) result(res)
+    logical :: res
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_) :: level
+    integer(psb_lpk_) :: aggsize
+    res =  amg_get_do_remap().and.(level>=2)
+!!$    res = .false.
+  end function amg_s_policy_do_remap
+
+  subroutine amg_s_hierarchy_bld_cmp_newsz(level,iszv,prevsize,&
+       & nlaggr,casize,mnratio,sizeratio,newsz)
+    implicit none 
+    integer(psb_ipk_) :: level,iszv,newsz
+    integer(psb_lpk_) :: nlaggr(:)
+    integer(psb_lpk_) :: prevsize, casize
+    real(psb_spk_)    :: mnratio, sizeratio
+    ! ==============================
+    integer(psb_lpk_) :: iaggsize
+
+    newsz    = 0 
+    iaggsize = sum(nlaggr)
+    sizeratio = prevsize
+    sizeratio = sizeratio/iaggsize
+!!$    write(0,*) 'From cmp_newsz: ',iaggsize,casize,&
+!!$         & sizeratio,mnratio, level
+
+    if (iaggsize <= casize) newsz = level      
+    if (level == iszv)      newsz = level
+
+    if (level>2) then
+      if (sizeratio < mnratio) then
+        if (sizeratio > 1) then
+          newsz = level
+        else
+          !
+          ! We are not gaining 
+          !
+          newsz = level-1
+        end if
+      end if
+    end if
+!!$    write(0,*) 'At end of cmp_newsz ',newsz
+  end subroutine amg_s_hierarchy_bld_cmp_newsz
+
 end subroutine amg_s_hierarchy_bld

amgprec/impl/amg_s_smoothers_bld.f90

@@ -136,9 +136,9 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
   !
   ! Check to ensure all procs have the same
   !
-  iszv       = size(prec%precv)
+  iszv       = prec%get_nlevs()
   call psb_bcast(ctxt,iszv)
-  if (iszv /= size(prec%precv)) then
+  if (iszv /= prec%get_nlevs()) then
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999

amgprec/impl/amg_sfile_prec_descr.f90

@@ -136,7 +136,7 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
       ! ensured by amg_precbld).
       !
       if (me == root_) then
-        nlev = size(prec%precv)
+        nlev = prec%get_nlevs()
         do ilev = 1, nlev 
           if (.not.allocated(prec%precv(ilev)%sm)) then 
             info = 3111
@@ -152,7 +152,7 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
         write(iout_,*) trim(prefix_),' Base matrix      : ',&
              & gl_nrows, gl_ncols, gl_nzeros
         write(iout_,*)
-        
+        write(iout_,*) 'At level :',1,' we have ',np,' processes'
         if (nlev == 1) then
           !
           ! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.

amgprec/impl/amg_smlprec_aply.f90

@@ -207,6 +207,7 @@ subroutine amg_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
 
   use psb_base_mod
   use amg_base_prec_type
+  use amg_prec_mod
   use amg_s_inner_mod, amg_protect_name => amg_smlprec_aply_vect
 
   implicit none
@@ -243,10 +244,10 @@ subroutine amg_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
 
   if (debug_level >= psb_debug_inner_) &
        & write(debug_unit,*) me,' ',trim(name),&
-       & ' Entry  ', size(p%precv)
+       & ' Entry  ', p%get_nlevs()
 
   trans_ = psb_toupper(trans)
-  nlev   = size(p%precv)
+  nlev   = p%get_nlevs()
 
   do_alloc_wrk = .not.allocated(p%precv(1)%wrk)
 
@@ -381,7 +382,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_ml')
@@ -393,39 +394,38 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
     end if
-    if (me >= 0) then
-      select case(p%precv(level)%parms%ml_cycle) 
-        
-      case(amg_no_ml_)
-        !
-        ! No preconditioning, should not really get here
-        ! 
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='amg_no_ml_ in mlprc_aply?')
-        goto 9999      
-        
-      case(amg_add_ml_)
-        
-        call amg_s_inner_add(p, level, trans, work)
-        
-      case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
-        
-        call amg_s_inner_mult(p, level, trans, work)
-        
-      case(amg_kcycle_ml_, amg_kcyclesym_ml_)
-        
-        call amg_s_inner_k_cycle(p, level, trans, work)
-        
-      case default
-        info = psb_err_from_subroutine_ai_
-        call psb_errpush(info,name,a_err='invalid ml_cycle',&
-             &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
-        goto 9999      
-        
-      end select
-      if(debug_level > 1) then
-        write(debug_unit,*) me,' End inner_ml_aply at level ',level
-      end if
+    
+    select case(p%precv(level)%parms%ml_cycle) 
+      
+    case(amg_no_ml_)
+      !
+      ! No preconditioning, should not really get here
+      ! 
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='amg_no_ml_ in mlprc_aply?')
+      goto 9999      
+      
+    case(amg_add_ml_)
+      
+      call amg_s_inner_add(p, level, trans, work)
+      
+    case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
+      
+      call amg_s_inner_mult(p, level, trans, work)
+      
+    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
+      
+      call amg_s_inner_k_cycle(p, level, trans, work)
+      
+    case default
+      info = psb_err_from_subroutine_ai_
+      call psb_errpush(info,name,a_err='invalid ml_cycle',&
+           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
+      goto 9999      
+      
+    end select
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' End inner_ml_aply at level ',level
     end if
 
     call psb_erractionrestore(err_act)
@@ -468,7 +468,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_add')
@@ -492,12 +492,13 @@ contains
          & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
          & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
          & wv => p%precv(level)%wrk%wv)
-
+      
       if (me >= 0) then 
         if (allocated(p%precv(level)%sm2a)) then
           call psb_geaxpby(sone,vx2l,szero,vy2l,base_desc,info)
           
-          sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
+          sweeps = max(p%precv(level)%parms%sweeps_pre,&
+               & p%precv(level)%parms%sweeps_post)
           do k=1, sweeps
             call p%precv(level)%sm%apply(sone,&
                  & vy2l,szero,vty,&
@@ -509,7 +510,6 @@ contains
                  & base_desc, trans,&
                  & ione,work,wv,info,init='Z')        
           end do
-          
         else
           sweeps = p%precv(level)%parms%sweeps_pre
           call p%precv(level)%sm%apply(sone,&
@@ -523,40 +523,37 @@ contains
              & a_err='Error during ADD smoother_apply')
         goto 9999
       end if
-
+      
       if (level < nlev) then
         ! Apply the restriction
         call p%precv(level+1)%map_rstr(sone,vx2l,&
              & szero,p%precv(level+1)%wrk%vx2l,&
-             & info,work=work,&
-             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+             & info,work=work,vtx=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during restriction')
           goto 9999
         end if
-
+        
         call inner_ml_aply(level+1,p,trans,work,info)
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error in recursive call')
           goto 9999
         end if
-
+        
         !
         ! Apply the prolongator
         !  
         call p%precv(level+1)%map_prol(sone,&
              & p%precv(level+1)%wrk%vy2l, sone,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work, vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
           goto 9999
         end if
-
-
+        
       end if
     end associate
     
@@ -597,7 +594,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_mult')
@@ -608,7 +605,7 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' inner_mult at level ',level
     end if
-
+!!$    write(debug_unit,*) me,' inner_mult at level (1):',level,np
     sweeps_post = p%precv(level)%parms%sweeps_post
     sweeps_pre  = p%precv(level)%parms%sweeps_pre
     pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
@@ -618,6 +615,10 @@ contains
          & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
          & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
          & wv => p%precv(level)%wrk%wv)
+!!$      write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',&
+!!$           & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv)
+      if (me >=0) then
+      
       if (level < nlev) then 
         !
         ! Apply the first smoother
@@ -625,7 +626,6 @@ contains
         !
 
         if (pre) then
-          if (me >=0) then
 !!$            write(0,*) me,'Applying smoother pre ', level
             if (trans == 'N') then 
               sweeps = p%precv(level)%parms%sweeps_pre
@@ -644,28 +644,29 @@ contains
                    & a_err='Error during PRE smoother_apply')
               goto 9999
             end if
-          end if
-        endif
+      
+          endif
         !
         ! Compute the residual for next level and call recursively
         !
         if (pre) then
-          call psb_geaxpby(sone,vx2l,&
-               & szero,vty,&
-               & base_desc,info)
-
-          if (info == psb_success_) call psb_spmm(-sone,base_a,&
-               & vy2l,sone,vty,&
-               & base_desc,info,work=work,trans=trans)
-          if (info /= psb_success_) then
-            call psb_errpush(psb_err_internal_error_,name,&
-                 & a_err='Error during residue')
-            goto 9999
-          end if
+            
+            call psb_geaxpby(sone,vx2l,&
+                 & szero,vty,&
+                 & base_desc,info)
+            
+            if (info == psb_success_) call psb_spmm(-sone,base_a,&
+                 & vy2l,sone,vty,&
+                 & base_desc,info,work=work,trans=trans)
+            if (info /= psb_success_) then
+              call psb_errpush(psb_err_internal_error_,name,&
+                   & a_err='Error during residue')
+              goto 9999
+            end if
+          
           call p%precv(level+1)%map_rstr(sone,vty,&
                & szero,p%precv(level+1)%wrk%vx2l,&
-               & info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & info,work=work,vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -675,8 +676,7 @@ contains
           ! Shortcut: just transfer x2l. 
           call p%precv(level+1)%map_rstr(sone,vx2l,&
                & szero,p%precv(level+1)%wrk%vx2l,&
-               & info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & info,work=work,vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -691,8 +691,7 @@ contains
         !  
         call p%precv(level+1)%map_prol(sone,&
              & p%precv(level+1)%wrk%vy2l,sone,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work,vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
@@ -701,17 +700,17 @@ contains
 
         if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
 
-          if (me >=0) then 
+          
             call psb_geaxpby(sone,vx2l, szero,vty,&
                  & base_desc,info)        
             if (info == psb_success_) call psb_spmm(-sone,base_a,&
                  & vy2l,sone,vty,&
                  & base_desc,info,work=work,trans=trans)
-          end if
+          
           if (info == psb_success_) &
                & call p%precv(level+1)%map_rstr(sone,vty,&
                & szero,p%precv(level+1)%wrk%vx2l,info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during W-cycle restriction')
@@ -722,8 +721,7 @@ contains
 
           if (info == psb_success_) call p%precv(level+1)%map_prol(sone, &
                & p%precv(level+1)%wrk%vy2l,sone,vy2l,&
-               & info,work=work,&
-               & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+               & info,work=work,vty=wv(1))
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -735,7 +733,7 @@ contains
 
 
         if (post) then
-          if (me >=0) then 
+          
             call psb_geaxpby(sone,vx2l,&
                  & szero,vty,&
                  & base_desc,info)
@@ -762,7 +760,7 @@ contains
                    & vty,sone,vy2l, base_desc, trans,&
                    & sweeps,work,wv,info,init='Z')
             end if
-          end if
+          
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -789,6 +787,7 @@ contains
              & a_err='Invalid LEVEL vs NLEV')
         goto 9999
       end if
+    end if
     end associate
 9998 continue
     call psb_erractionrestore(err_act)
@@ -833,7 +832,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_add')
@@ -910,7 +909,7 @@ contains
         call  p%precv(level + 1)%map_rstr(sone,vty,&
              & szero,p%precv(level + 1)%wrk%vx2l,&
              &info,work=work,&
-             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+             & vtx=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -945,8 +944,7 @@ contains
         !  
         call p%precv(level+1)%map_prol(sone,&
              & p%precv(level+1)%wrk%vy2l,sone,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work,vty=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -1007,9 +1005,6 @@ contains
   end subroutine amg_s_inner_k_cycle
   
   recursive subroutine amg_sinneritkcycle(p, level, trans, work, innersolv)
-    use psb_base_mod
-    use amg_prec_mod
-    use amg_s_inner_mod, amg_protect_name => amg_smlprec_aply
 
     implicit none
 
@@ -1161,532 +1156,3 @@ contains
 
 end subroutine amg_smlprec_aply_vect
 
-
-!
-! Old routine for arrays instead of psb_X_vector. To be deleted eventually.
-!
-!
-subroutine amg_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
-
-  use psb_base_mod
-  use amg_base_prec_type
-  use amg_s_inner_mod, amg_protect_name => amg_smlprec_aply
-
-  implicit none
-
-  ! Arguments
-  type(psb_desc_type),intent(in)    :: desc_data
-  type(amg_sprec_type), intent(inout)  :: p
-  real(psb_spk_),intent(in)         :: alpha,beta
-  real(psb_spk_),intent(inout)      :: x(:)
-  real(psb_spk_),intent(inout)      :: y(:)
-  character, intent(in)             :: trans
-  real(psb_spk_),target             :: work(:)
-  integer(psb_ipk_), intent(out)              :: info
-
-  ! Local variables
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: np, me
-  integer(psb_ipk_)   :: err_act
-  integer(psb_ipk_)   :: debug_level, debug_unit, nlev,nc2l,nr2l,level
-  character(len=20)   :: name
-  character           :: trans_
-  type amg_mlwrk_type
-    real(psb_spk_), allocatable  :: tx(:), ty(:), x2l(:), y2l(:)
-  end type amg_mlwrk_type
-  type(amg_mlwrk_type), allocatable, target  :: mlwrk(:)
-
-  name='amg_smlprec_aply'
-  info = psb_success_
-  call psb_erractionsave(err_act)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-
-  ctxt = desc_data%get_context()
-  call psb_info(ctxt, me, np)
-
-  if (debug_level >= psb_debug_inner_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & ' Entry  ', size(p%precv)
-
-  trans_ = psb_toupper(trans)
-
-  nlev = size(p%precv)
-  allocate(mlwrk(nlev),stat=info) 
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
-    goto 9999      
-  end if
-  level = 1
-
-  do level = 1, nlev
-    call psb_geasb(mlwrk(level)%x2l,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%y2l,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%tx,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%ty,&
-         & p%precv(level)%base_desc,info)
-    if (psb_errstatus_fatal()) then 
-      nc2l = p%precv(level)%base_desc%get_local_cols()
-      info=psb_err_alloc_request_
-      call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
-           & a_err='real(psb_spk_)')
-      goto 9999      
-    end if
-  end do
-
-  mlwrk(level)%x2l(:) = x(:) 
-  mlwrk(level)%y2l(:) = szero 
-
-  call inner_ml_aply(level,p,mlwrk,trans_,work,info)    
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,&
-         & a_err='Inner prec aply')
-    goto 9999
-  end if
-
-  call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,&
-       &   p%precv(level)%base_desc,info)
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,&
-         & a_err='Error final update')
-    goto 9999
-  end if
-
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-
-contains
-
-    !
-  !
-  ! inner_ml_aply: apply AMG at a given level.
-  ! This routine dispatches the computation according to the type
-  ! specified at the current level.
-  ! Each of the corrections will inturn call recursively this routine.
-  !
-  ! Assumptions:
-  ! On input:
-  !   mlprec_wkr(level)%vx2l   contains the input vector (RHS)
-  !   mlprec_wkr(level)%vy2l   contains the initial guess
-  !
-  ! On output:
-  !   mlprec_wkr(level)%vy2l   contains the solution
-  !
-  ! Constraints: each of the called routines must properly handle
-  ! the input/output conditions for level+1 (i.e. apply
-  ! prolongation/restriction).
-  ! Note: for historical/convenience reasons the prolongator/restrictor
-  ! between level and level+1 are stored at level+1. 
-  !
-  !
-  recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info)    
-
-    implicit none 
-
-    ! Arguments
-    integer(psb_ipk_)                           :: level 
-    type(amg_sprec_type), target, intent(inout) :: p
-    type(amg_mlwrk_type), intent(inout), target    :: mlwrk(:)
-    character, intent(in)                       :: trans
-    real(psb_spk_),target                      :: work(:)
-    integer(psb_ipk_), intent(out)              :: info
-
-    type(psb_s_vect_type) :: res
-    type(psb_s_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_ml_aply'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_ml')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_ml_aply at level ',level
-    end if
-
-    select case(p%precv(level)%parms%ml_cycle) 
-
-    case(amg_no_ml_)
-      !
-      ! No preconditioning, should not really get here
-      ! 
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='amg_no_ml_ in mlprc_aply?')
-      goto 9999      
-
-    case(amg_add_ml_)
-
-      call amg_s_inner_add(p, mlwrk, level, trans, work)
-
-    case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_)
-
-      call amg_s_inner_mult(p, mlwrk, level, trans, work)
-      
-! !$    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
-! !$
-! !$      call amg_s_inner_k_cycle(p, mlwrk, level, trans, work)
-      
-    case default
-      info = psb_err_from_subroutine_ai_
-      call psb_errpush(info,name,a_err='invalid ml_cycle',&
-           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
-      goto 9999      
-
-    end select
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine inner_ml_aply
-
-
-  recursive subroutine amg_s_inner_add(p, mlwrk, level, trans, work)
-    use psb_base_mod
-    use amg_prec_mod
-
-    implicit none
-
-    !Input/Oputput variables
-    type(amg_sprec_type), intent(inout)  :: p
-
-    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
-    integer(psb_ipk_), intent(in) :: level
-    character, intent(in)             :: trans
-    real(psb_spk_),target            :: work(:)
-    type(psb_s_vect_type) :: res
-    type(psb_s_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_inner_add'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_add')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_add at level ',level
-    end if
-
-    if ((level<1).or.(level>nlev)) then
-      info = psb_err_internal_error_ 
-      call psb_errpush(info,name,&
-           & a_err='Invalid LEVEL>NLEV')
-      goto 9999
-    end if
-    
-    sweeps = p%precv(level)%parms%sweeps_pre
-    call p%precv(level)%sm%apply(sone,&
-         & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,&
-         & p%precv(level)%base_desc, trans,&
-         & sweeps,work,info)
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Error during ADD smoother_apply')
-      goto 9999
-    end if
-
-    if (level < nlev) then
-      ! Apply the restriction
-      call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,&
-           & szero,mlwrk(level+1)%x2l,&
-           & info,work=work)
-      mlwrk(level+1)%y2l(:) = szero
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during restriction')
-        goto 9999
-      end if
-      
-      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error in recursive call')
-        goto 9999
-      end if
-
-      !
-      ! Apply the prolongator and add correction.
-      !  
-      call p%precv(level+1)%map_prol(sone,&
-           & mlwrk(level+1)%y2l,sone,mlwrk(level)%y2l,&
-           & info,work=work)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during prolongation')
-        goto 9999
-      end if
-
-
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine amg_s_inner_add
-
-  recursive subroutine amg_s_inner_mult(p, mlwrk, level, trans, work)
-    use psb_base_mod
-    use amg_prec_mod
-
-    implicit none
-
-    !Input/Oputput variables
-    type(amg_sprec_type), intent(inout)  :: p
-
-    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
-    integer(psb_ipk_), intent(in) :: level
-    character, intent(in)             :: trans
-    real(psb_spk_),target            :: work(:)
-    type(psb_s_vect_type) :: res
-    type(psb_s_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_inner_mult'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_mult')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_mult at level ',level
-    end if
-
-    if ((level < nlev).or.(nlev == 1)) then
-      sweeps_post = p%precv(level)%parms%sweeps_post
-      sweeps_pre  = p%precv(level)%parms%sweeps_pre
-    else
-      sweeps_post = p%precv(level-1)%parms%sweeps_post
-      sweeps_pre  = p%precv(level-1)%parms%sweeps_pre
-    endif
-
-    pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
-    post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N'))
-
-    
-    if (level < nlev) then 
-
-      !
-      ! Apply the first smoother
-      !
-
-      if (pre) then
-        if (trans == 'N') then 
-          sweeps = p%precv(level)%parms%sweeps_pre
-          if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
-               & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Y')
-        else
-          sweeps = p%precv(level)%parms%sweeps_post
-          if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
-               & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Y')
-        end if
-        
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during PRE smoother_apply')
-          goto 9999
-        end if
-      endif
-
-      !
-      ! Compute the residual and call recursively
-      !
-      if (pre) then
-        call psb_geaxpby(sone,mlwrk(level)%x2l,&
-             & szero,mlwrk(level)%ty,&
-             & p%precv(level)%base_desc,info)
-        
-        if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,&
-             & mlwrk(level)%y2l,sone,mlwrk(level)%ty,&
-             & p%precv(level)%base_desc,info,work=work,trans=trans)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during residue')
-          goto 9999
-        end if
-        call p%precv(level+1)%map_rstr(sone,mlwrk(level)%ty,&
-             & szero,mlwrk(level+1)%x2l,info,work=work)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during restriction')
-          goto 9999
-        end if
-      else
-        ! Shortcut: just transfer x2l. 
-        call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,&
-             & szero,mlwrk(level+1)%x2l,info,work=work)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during restriction')
-          goto 9999
-        end if
-      endif
-      ! First guess is zero
-      mlwrk(level+1)%y2l(:) = szero
-      
-      
-      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      
-      if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
-        ! On second call will use output y2l as initial guess
-        if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      endif
-      
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error in recursive call')
-        goto 9999
-      end if
-      
-      
-      !
-      ! Apply the prolongator
-      !  
-      call p%precv(level+1)%map_prol(sone,mlwrk(level+1)%y2l,&
-           & sone,mlwrk(level)%y2l,info,work=work)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during prolongation')
-        goto 9999
-      end if
-      
-      !
-      ! Compute the residual
-      !
-      if (post) then
-        call psb_geaxpby(sone,mlwrk(level)%x2l,&
-             & szero,mlwrk(level)%tx,&
-             & p%precv(level)%base_desc,info)
-        call psb_spmm(-sone,p%precv(level)%base_a,mlwrk(level)%y2l,&
-             & sone,mlwrk(level)%tx,p%precv(level)%base_desc,info,&
-             & work=work,trans=trans)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during residue')
-          goto 9999
-        end if
-        !
-        ! Apply the second smoother
-        !
-        if (trans == 'N') then
-          sweeps = p%precv(level)%parms%sweeps_post
-          if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
-               & mlwrk(level)%tx,sone,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Z')
-        else 
-          sweeps = p%precv(level)%parms%sweeps_pre
-          if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
-               & mlwrk(level)%tx,sone,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Z')
-        end if
-        
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during POST smoother_apply')
-          goto 9999
-        end if
-        
-      endif            
-      
-    else if (level == nlev) then
-      
-      sweeps = p%precv(level)%parms%sweeps_pre
-      if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
-           & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,&
-           & p%precv(level)%base_desc, trans,&
-           & sweeps,work,info)
-
-    else
-
-      info = psb_err_internal_error_ 
-      call psb_errpush(info,name,&
-           & a_err='Invalid LEVEL vs NLEV')
-      goto 9999
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine amg_s_inner_mult
-    
-
-end subroutine amg_smlprec_aply

amgprec/impl/amg_smlprec_aply_a.f90

@@ -0,0 +1,733 @@
+!  
+!   
+!                             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 prior written permission.
+!   
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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_smlprec_aply.f90
+!
+! Subroutine: amg_smlprec_aply
+! Version:    real
+!
+!  Current version of this file contributed by:
+!        Ambra Abdullahi Hassan 
+!
+!
+!  This routine computes
+!  
+!                        Y = beta*Y + alpha*op(ML^(-1))*X,
+!  where 
+!  - ML is a multilevel preconditioner associated with
+!    a certain matrix A and stored in p,
+!  - op(ML^(-1)) is ML^(-1) or its transpose, according to the value of trans,
+!  - X and Y are vectors,
+!  - alpha and beta are scalars.
+!
+!  The following multilevel strategies can be applied:
+!
+!  - Additive multilevel Schwarz,
+!  - classical V-cycle,
+!  - classical W-cycle,
+!  - K-cycle both for symmetric and nonsymmetric matrices, where 2 iterations
+!    of FCG(1) or GCR, respectively, are applied at each level
+!    except the coarsest.
+!
+!  For each level we have as many submatrices as processes (except for the coarsest
+!  level where we might have a replicated index space) and each process takes care
+!  of one submatrix.
+!
+!  A multilevel preconditioner is regarded as an array of 'one-level' data structures,
+!  each containing the part of the preconditioner associated to a certain level
+!  (for more details see the description of amg_Tonelev_type in amg_prec_type.f90).
+!  For each level lev, there is a smoother stored in
+!     p%precv(lev)%sm
+!  which in turn contains a solver
+!     p$precv(lev)%sm%sv
+!  Typically the solver acts only locally, and the smoother applies any required
+!  parallel communication/action. 
+!  Each level has  a matrix A(lev), obtained by 'tranferring' the original
+!  matrix A (i.e. the matrix to be preconditioned) to the level lev, through smoothed
+!  aggregation.
+!
+!  The levels are numbered in increasing order starting from the finest one, i.e.
+!  level 1 is the finest level and A(1) is the matrix A.
+!
+!  This routine is formulated in a recursive way, so it is quite compact.
+!
+!  The V-cycle can be described as follows, where
+!  P(lev) denotes the smoothed prolongator from level lev to level
+!  lev-1, while R(lev) denotes the corresponding  restriction operator
+!  (normally its transpose) from level lev-1 to level lev.
+!  M(lev) is the smoother at the current level.
+!
+!
+!   1. Transfer the outer vector Xest to u(1) (inner X at level 1)
+!
+!   2. Invoke V-cycle(1,M,P,R,A,b,u)
+!
+!    procedure V-cycle(lev,M,P,R,A,b,u)
+!
+!      if (lev < nlev) then
+!
+!         u(lev)   = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev))
+!
+!         b(lev+1) = R(lev+1)*(b(lev)-A(lev)*u(lev))
+!
+!         u(lev+1) = V-cycle(lev+1,M,P,R,A,b,u)
+!
+!         u(lev)   = u(lev) + P(lev+1) * u(lev+1)
+!
+!         u(lev)   = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev))
+!
+!      else
+!
+!         solve  A(lev)*u(lev) = b(lev)
+!
+!      end if
+!
+!      return u(lev)
+!    end
+!
+!   3. Transfer u(1) to the external:
+!         Yext = beta*Yext + alpha*u(1)
+!
+!
+!  In the implementation, the recursive procedure is inner_ml_aply, which
+!  in turn uses amg_inner_add (for additive multilevel),
+!  amg_inner_mult (for V-cycle and W-cycle), and
+!  amg_inner_k_cycle (for symmetric and non-symmetric K-cycle).
+!  
+!  For a detailed description of the algorithms, see:
+!
+!  - B.F. Smith, P.E. Bjorstad, W.D. Gropp,
+!    Domain decomposition: parallel multilevel methods for elliptic partial
+!    differential equations, Cambridge University Press, 1996.
+!
+!  - W. L. Briggs, V. E. Henson, S. F.  McCormick,
+!    A Multigrid Tutorial, Second Edition
+!    SIAM, 2000.
+!
+!  - K. Stuben,
+!    An Introduction to Algebraic Multigrid,
+!    in A. Schuller, U. Trottenberg, C. Oosterlee, Multigrid, Academic Press, 2001.
+!
+!  - Y. Notay, P. S. Vassilevski,
+!    Recursive Krylov-based multigrid cycles
+!    Numerical Linear Algebra with Applications, 15 (5), 2008, 473--487.
+!
+!
+! Arguments:
+!   alpha      -   real(psb_spk_), input.
+!                  The scalar alpha.
+!   p          -   type(amg_sprec_type), input.
+!                  The multilevel preconditioner data structure containing the
+!                  local part of the preconditioner to be applied.
+!      Note that nlev = size(p%precv) = number of levels.
+!      p%precv(lev)%sm        -  type(psb_sbaseprec_type)
+!                                 The pre-'smoother' for the current level
+!      p%precv(lev)%sm2       -  type(psb_sbaseprec_type)
+!                                 The post-'smoother' for the current level
+!                                 may be the same or different from %sm
+!      p%precv(lev)%ac        -  type(psb_sspmat_type) 
+!                                 The local part of the matrix A(lev).
+!      p%precv(lev)%parms     -  type(psb_sml_parms) 
+!                                 Parameters controllin the multilevel prec. 
+!      p%precv(lev)%desc_ac   -  type(psb_desc_type).
+!                                 The communication descriptor associated to the sparse
+!                                 matrix A(lev)
+!      p%precv(lev)%map       -  type(psb_inter_desc_type)
+!                                 Stores the linear operators mapping level (lev-1)
+!                                 to (lev) and vice versa. These are the restriction
+!                                 and prolongation operators described in the sequel. 
+!      p%precv(lev)%base_a    -  type(psb_sspmat_type), pointer.
+!                                 Pointer (really a pointer!) to the base matrix of
+!                                 the current level, i.e. the local part of A(lev);
+!                                 so we have a unified treatment of residuals. We
+!                                 need this to avoid passing explicitly the matrix
+!                                 A(lev) to the routine which applies the
+!                                 preconditioner.
+!      p%precv(lev)%base_desc -  type(psb_desc_type), pointer.
+!                                 Pointer to the communication descriptor associated
+!                                 to the sparse matrix pointed by base_a.  
+!                  
+!   x          -  real(psb_spk_), dimension(:), input.
+!                 The local part of the vector X.
+!   beta       -  real(psb_spk_), input.
+!                 The scalar beta.
+!   y          -  real(psb_spk_), dimension(:), input/output.
+!                 The local part of the vector Y.
+!   desc_data  -  type(psb_desc_type), input.
+!                 The communication descriptor associated to the matrix to be
+!                 preconditioned.
+!   trans      -  character, optional.
+!                 If trans='N','n' then op(M^(-1)) = M^(-1);
+!                 if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)).
+!   work       -  real(psb_spk_), dimension (:), optional, target.
+!                 Workspace. Its size must be at least 4*desc_data%get_local_cols().
+!   info       -  integer, output.
+!                 Error code.
+!
+!   Note that when the LU factorization of the matrix A(lev) is computed instead of
+!   the ILU one, by using UMFPACK or SuperLU or MUMPS, the corresponding
+!   L and U factors are stored in data structures handled
+!   by the third party software. 
+!
+
+!
+! Old routine for arrays instead of psb_X_vector. To be deleted eventually.
+!
+!
+subroutine amg_smlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info)
+
+  use psb_base_mod
+  use amg_base_prec_type
+  use amg_s_inner_mod, amg_protect_name => amg_smlprec_aply_a
+
+  implicit none
+
+  ! Arguments
+  type(psb_desc_type),intent(in)    :: desc_data
+  type(amg_sprec_type), intent(inout)  :: p
+  real(psb_spk_),intent(in)         :: alpha,beta
+  real(psb_spk_),intent(inout)      :: x(:)
+  real(psb_spk_),intent(inout)      :: y(:)
+  character, intent(in)             :: trans
+  real(psb_spk_),target             :: work(:)
+  integer(psb_ipk_), intent(out)              :: info
+
+  ! Local variables
+  type(psb_ctxt_type) :: ctxt
+  integer(psb_ipk_)   :: np, me
+  integer(psb_ipk_)   :: err_act
+  integer(psb_ipk_)   :: debug_level, debug_unit, nlev,nc2l,nr2l,level
+  character(len=20)   :: name
+  character           :: trans_
+  type amg_mlwrk_type
+    real(psb_spk_), allocatable  :: tx(:), ty(:), x2l(:), y2l(:)
+  end type amg_mlwrk_type
+  type(amg_mlwrk_type), allocatable, target  :: mlwrk(:)
+
+  name='amg_smlprec_aply'
+  info = psb_success_
+  call psb_erractionsave(err_act)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  ctxt = desc_data%get_context()
+  call psb_info(ctxt, me, np)
+
+  if (debug_level >= psb_debug_inner_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & ' Entry  ', size(p%precv)
+
+  trans_ = psb_toupper(trans)
+
+  nlev = size(p%precv)
+  allocate(mlwrk(nlev),stat=info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
+    goto 9999      
+  end if
+  level = 1
+
+  do level = 1, nlev
+    call psb_geasb(mlwrk(level)%x2l,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%y2l,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%tx,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%ty,&
+         & p%precv(level)%base_desc,info)
+    if (psb_errstatus_fatal()) then 
+      nc2l = p%precv(level)%base_desc%get_local_cols()
+      info=psb_err_alloc_request_
+      call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
+           & a_err='real(psb_spk_)')
+      goto 9999      
+    end if
+  end do
+
+  mlwrk(level)%x2l(:) = x(:) 
+  mlwrk(level)%y2l(:) = szero 
+
+  call inner_ml_aply(level,p,mlwrk,trans_,work,info)    
+
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_internal_error_,name,&
+         & a_err='Inner prec aply')
+    goto 9999
+  end if
+
+  call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,&
+       &   p%precv(level)%base_desc,info)
+
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_internal_error_,name,&
+         & a_err='Error final update')
+    goto 9999
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+
+contains
+
+    !
+  !
+  ! inner_ml_aply: apply AMG at a given level.
+  ! This routine dispatches the computation according to the type
+  ! specified at the current level.
+  ! Each of the corrections will inturn call recursively this routine.
+  !
+  ! Assumptions:
+  ! On input:
+  !   mlprec_wkr(level)%vx2l   contains the input vector (RHS)
+  !   mlprec_wkr(level)%vy2l   contains the initial guess
+  !
+  ! On output:
+  !   mlprec_wkr(level)%vy2l   contains the solution
+  !
+  ! Constraints: each of the called routines must properly handle
+  ! the input/output conditions for level+1 (i.e. apply
+  ! prolongation/restriction).
+  ! Note: for historical/convenience reasons the prolongator/restrictor
+  ! between level and level+1 are stored at level+1. 
+  !
+  !
+  recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info)    
+
+    implicit none 
+
+    ! Arguments
+    integer(psb_ipk_)                           :: level 
+    type(amg_sprec_type), target, intent(inout) :: p
+    type(amg_mlwrk_type), intent(inout), target    :: mlwrk(:)
+    character, intent(in)                       :: trans
+    real(psb_spk_),target                      :: work(:)
+    integer(psb_ipk_), intent(out)              :: info
+
+    type(psb_s_vect_type) :: res
+    type(psb_s_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_ml_aply'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_ml')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_ml_aply at level ',level
+    end if
+
+    select case(p%precv(level)%parms%ml_cycle) 
+
+    case(amg_no_ml_)
+      !
+      ! No preconditioning, should not really get here
+      ! 
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='amg_no_ml_ in mlprc_aply?')
+      goto 9999      
+
+    case(amg_add_ml_)
+
+      call amg_s_inner_add(p, mlwrk, level, trans, work)
+
+    case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_)
+
+      call amg_s_inner_mult(p, mlwrk, level, trans, work)
+      
+! !$    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
+! !$
+! !$      call amg_s_inner_k_cycle(p, mlwrk, level, trans, work)
+      
+    case default
+      info = psb_err_from_subroutine_ai_
+      call psb_errpush(info,name,a_err='invalid ml_cycle',&
+           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
+      goto 9999      
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine inner_ml_aply
+
+  recursive subroutine amg_s_inner_add(p, mlwrk, level, trans, work)
+    use psb_base_mod
+    use amg_prec_mod
+
+    implicit none
+
+    !Input/Oputput variables
+    type(amg_sprec_type), intent(inout)  :: p
+
+    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
+    integer(psb_ipk_), intent(in) :: level
+    character, intent(in)             :: trans
+    real(psb_spk_),target            :: work(:)
+    type(psb_s_vect_type) :: res
+    type(psb_s_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_inner_add'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_add')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_add at level ',level
+    end if
+
+    if ((level<1).or.(level>nlev)) then
+      info = psb_err_internal_error_ 
+      call psb_errpush(info,name,&
+           & a_err='Invalid LEVEL>NLEV')
+      goto 9999
+    end if
+    
+    sweeps = p%precv(level)%parms%sweeps_pre
+    call p%precv(level)%sm%apply(sone,&
+         & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,&
+         & p%precv(level)%base_desc, trans,&
+         & sweeps,work,info)
+    if (info /= psb_success_) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='Error during ADD smoother_apply')
+      goto 9999
+    end if
+
+    if (level < nlev) then
+      ! Apply the restriction
+      call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,&
+           & szero,mlwrk(level+1)%x2l,&
+           & info,work=work)
+      mlwrk(level+1)%y2l(:) = szero
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during restriction')
+        goto 9999
+      end if
+      
+      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in recursive call')
+        goto 9999
+      end if
+
+      !
+      ! Apply the prolongator and add correction.
+      !  
+      call p%precv(level+1)%map_prol(sone,&
+           & mlwrk(level+1)%y2l,sone,mlwrk(level)%y2l,&
+           & info,work=work)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during prolongation')
+        goto 9999
+      end if
+
+
+    end if
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine amg_s_inner_add
+
+  recursive subroutine amg_s_inner_mult(p, mlwrk, level, trans, work)
+    use psb_base_mod
+    use amg_prec_mod
+
+    implicit none
+
+    !Input/Oputput variables
+    type(amg_sprec_type), intent(inout)  :: p
+
+    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
+    integer(psb_ipk_), intent(in) :: level
+    character, intent(in)             :: trans
+    real(psb_spk_),target            :: work(:)
+    type(psb_s_vect_type) :: res
+    type(psb_s_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_inner_mult'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_mult')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_mult at level ',level
+    end if
+
+    if ((level < nlev).or.(nlev == 1)) then
+      sweeps_post = p%precv(level)%parms%sweeps_post
+      sweeps_pre  = p%precv(level)%parms%sweeps_pre
+    else
+      sweeps_post = p%precv(level-1)%parms%sweeps_post
+      sweeps_pre  = p%precv(level-1)%parms%sweeps_pre
+    endif
+
+    pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
+    post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N'))
+
+    
+    if (level < nlev) then 
+
+      !
+      ! Apply the first smoother
+      !
+
+      if (pre) then
+        if (trans == 'N') then 
+          sweeps = p%precv(level)%parms%sweeps_pre
+          if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
+               & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Y')
+        else
+          sweeps = p%precv(level)%parms%sweeps_post
+          if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
+               & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Y')
+        end if
+        
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during PRE smoother_apply')
+          goto 9999
+        end if
+      endif
+
+      !
+      ! Compute the residual and call recursively
+      !
+      if (pre) then
+        call psb_geaxpby(sone,mlwrk(level)%x2l,&
+             & szero,mlwrk(level)%ty,&
+             & p%precv(level)%base_desc,info)
+        
+        if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,&
+             & mlwrk(level)%y2l,sone,mlwrk(level)%ty,&
+             & p%precv(level)%base_desc,info,work=work,trans=trans)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during residue')
+          goto 9999
+        end if
+        call p%precv(level+1)%map_rstr(sone,mlwrk(level)%ty,&
+             & szero,mlwrk(level+1)%x2l,info,work=work)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during restriction')
+          goto 9999
+        end if
+      else
+        ! Shortcut: just transfer x2l. 
+        call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,&
+             & szero,mlwrk(level+1)%x2l,info,work=work)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during restriction')
+          goto 9999
+        end if
+      endif
+      ! First guess is zero
+      mlwrk(level+1)%y2l(:) = szero
+      
+      
+      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      
+      if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
+        ! On second call will use output y2l as initial guess
+        if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      endif
+      
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in recursive call')
+        goto 9999
+      end if
+      
+      
+      !
+      ! Apply the prolongator
+      !  
+      call p%precv(level+1)%map_prol(sone,mlwrk(level+1)%y2l,&
+           & sone,mlwrk(level)%y2l,info,work=work)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during prolongation')
+        goto 9999
+      end if
+      
+      !
+      ! Compute the residual
+      !
+      if (post) then
+        call psb_geaxpby(sone,mlwrk(level)%x2l,&
+             & szero,mlwrk(level)%tx,&
+             & p%precv(level)%base_desc,info)
+        call psb_spmm(-sone,p%precv(level)%base_a,mlwrk(level)%y2l,&
+             & sone,mlwrk(level)%tx,p%precv(level)%base_desc,info,&
+             & work=work,trans=trans)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during residue')
+          goto 9999
+        end if
+        !
+        ! Apply the second smoother
+        !
+        if (trans == 'N') then
+          sweeps = p%precv(level)%parms%sweeps_post
+          if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
+               & mlwrk(level)%tx,sone,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Z')
+        else 
+          sweeps = p%precv(level)%parms%sweeps_pre
+          if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
+               & mlwrk(level)%tx,sone,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Z')
+        end if
+        
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during POST smoother_apply')
+          goto 9999
+        end if
+        
+      endif            
+      
+    else if (level == nlev) then
+      
+      sweeps = p%precv(level)%parms%sweeps_pre
+      if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
+           & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,&
+           & p%precv(level)%base_desc, trans,&
+           & sweeps,work,info)
+
+    else
+
+      info = psb_err_internal_error_ 
+      call psb_errpush(info,name,&
+           & a_err='Invalid LEVEL vs NLEV')
+      goto 9999
+    end if
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine amg_s_inner_mult
+    
+
+end subroutine amg_smlprec_aply_a

amgprec/impl/amg_sprecinit.F90

@@ -223,9 +223,7 @@ subroutine amg_sprecinit(ctxt,prec,ptype,info)
     allocate(amg_s_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
     call prec%precv(ilev_)%default()
 
-
   case ('ML')
-
     nlev_ = prec%ag_data%max_levs
     ilev_ = 1
     allocate(prec%precv(nlev_),stat=info)
@@ -237,6 +235,8 @@ subroutine amg_sprecinit(ctxt,prec,ptype,info)
     do ilev_ = 1, nlev_
       call prec%precv(ilev_)%default()
     end do
+    call prec%set_nlevs(nlev_) 
+
     call prec%set('ML_CYCLE','VCYCLE',info)
     call prec%set('SMOOTHER_TYPE','FBGS',info)
 #if  defined(AMG_HAVE_MUMPS)
@@ -250,7 +250,6 @@ subroutine amg_sprecinit(ctxt,prec,ptype,info)
     write(psb_err_unit,*) name,&
          &': Warning: Unknown preconditioner type request "',ptype,'"'
     info = psb_err_pivot_too_small_
-
   end select
 
   call psb_erractionrestore(err_act)

amgprec/impl/amg_z_hierarchy_bld.F90

@@ -64,11 +64,9 @@
 !               Error code.              
 !  
 subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
-
   use psb_base_mod
   use amg_z_inner_mod
   use amg_z_prec_mod, amg_protect_name => amg_z_hierarchy_bld
-
   Implicit None
 
   ! Arguments
@@ -82,7 +80,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
   type(psb_ctxt_type) :: ctxt
   integer(psb_ipk_)   :: me,np
   integer(psb_ipk_)   :: err,i,k, err_act, iszv, newsz,&
-       & nplevs, mxplevs
+       & nplevs, mxplevs, level
   integer(psb_lpk_) :: iaggsize, casize, mncsize, mncszpp
   real(psb_dpk_)     :: mnaggratio, sizeratio, athresh, aomega
   class(amg_z_base_smoother_type), allocatable :: coarse_sm, med_sm, &
@@ -98,6 +96,9 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
   character(len=40)  :: ch_err
   integer(psb_ipk_), save  :: idx_bldtp=-1, idx_matasb=-1
   logical, parameter :: do_timings=.false.
+  logical             :: stop_hierarchy_loop
+  type(psb_ctxt_type) :: lctxt
+  integer(psb_ipk_)   :: lme,lnp
 
   info=psb_success_
   err=0
@@ -130,7 +131,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
   end if
   cpymat_ = .false.
   if (present(cpymat)) cpymat_ = cpymat
-  
+
   !
   ! Check to ensure all procs have the same 
   !   
@@ -139,7 +140,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
   mnaggratio = prec%ag_data%min_cr_ratio
   mncsize    = prec%ag_data%min_coarse_size
   mncszpp    = prec%ag_data%min_coarse_size_per_process
-  iszv       = size(prec%precv)
+  iszv       = prec%get_nlevs()
   call psb_bcast(ctxt,iszv)
   call psb_bcast(ctxt,mncsize)
   call psb_bcast(ctxt,mncszpp)
@@ -165,7 +166,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
     call psb_errpush(info,name,a_err='Inconsistent min_cr_ratio')
     goto 9999
   end if
-  if (iszv /= size(prec%precv)) then 
+  if (iszv /= prec%get_nlevs()) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999
@@ -180,6 +181,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
     call psb_errpush(info,name,a_err=ch_err)
     goto 9999
   endif
+
   if (iszv == 1) then
     !
     ! This is OK, since it may be called by the user even if there
@@ -227,7 +229,6 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
     casize = mncsize
   end if
   prec%ag_data%target_coarse_size = casize
-  
   nplevs = max(itwo,mxplevs)
 
   !
@@ -240,7 +241,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   end if
   !
-  ! First set desired number of levels
+  ! First set desired number of levels if different from default. 
   !
   if (iszv /= nplevs) then
     allocate(tprecv(nplevs),stat=info)
@@ -286,7 +287,8 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
       call prec%precv(i)%free(info)
     end do
     call move_alloc(tprecv,prec%precv)
-    iszv = size(prec%precv)
+    call prec%set_nlevs(nplevs)
+    iszv = prec%get_nlevs()
   end if
 
   !
@@ -301,15 +303,24 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
   end if
   call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
   prec%precv(1)%base_desc => prec%precv(1)%desc_ac
-  
+
+  !
+  ! Main build loop
+  !   
   newsz = 0
+  stop_hierarchy_loop = .false. 
   array_build_loop: do i=2, iszv
     !
     ! Check on the iprcparm contents: they should be the same
     ! on all processes.
     !
     call psb_bcast(ctxt,prec%precv(i)%parms)
-
+    !
+    ! Get current context: might have performed remapping
+    ! 
+    lctxt = prec%precv(i-1)%base_desc%get_ctxt()
+    call psb_info(lctxt,lme,lnp)
+!!$    write(0,*) 'Check at level',i,lme,lnp
     !
     ! Sanity checks on the parameters
     !
@@ -325,8 +336,8 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
          & write(debug_unit,*) me,' ',trim(name),&
          & 'Calling mlprcbld at level  ',i
     !
-    ! Build the mapping between levels i-1 and i and the matrix
-    ! at level i
+    ! Build the tentative mapping between levels i-1 and i
+    ! and the matrix at level i
     !
     if (do_timings) call psb_tic(idx_bldtp)
     if (info == psb_success_)&
@@ -348,47 +359,26 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
     ! Save op_prol just in case
     !
     call op_prol%clone(prec%precv(i)%tprol,info)
+
     !
     ! Check for early termination of aggregation loop. 
-    !      
-    iaggsize = sum(nlaggr)
-
-    sizeratio = iaggsize
-    if (i==2) then 
-      sizeratio = desc_a%get_global_rows()/sizeratio
+    !
+    if (i == 2) then 
+      call amg_z_hierarchy_bld_cmp_newsz(i,iszv,&
+           & desc_a%get_global_rows(),&
+           & nlaggr,casize,mnaggratio,sizeratio,newsz)
     else
-      sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
+      call amg_z_hierarchy_bld_cmp_newsz(i,iszv,&
+           & sum(prec%precv(i-1)%linmap%naggr),&
+           & nlaggr,casize,mnaggratio,sizeratio,newsz)
     end if
     prec%precv(i)%szratio = sizeratio
-
-    if (iaggsize <= casize) newsz = i      
-    if (i == iszv)          newsz = i
-
-    if (i>2) then
-      if (sizeratio < mnaggratio) then
-        !
-        ! We are not gaining 
-        !
-        newsz = i-1
-      end if
-
-      if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then 
-        newsz=i-1
-        if (me == 0) then 
-          write(debug_unit,*) trim(name),&
-               &': Warning: aggregates from level ',&
-               & newsz
-          write(debug_unit,*) trim(name),&
-               &':                       to level ',&
-               & iszv,' coincide.'
-          write(debug_unit,*) trim(name),&
-               &': Number of levels actually used :',newsz
-          write(debug_unit,*)
-        end if
-      end if
-    end if
     call psb_bcast(ctxt,newsz)
 
+    !
+    ! Handle reallocation, if needed, and then mat_asb to polish off the
+    ! construction
+    ! 
     if (newsz > 0) then
       !
       ! This is awkward, we are saving the aggregation parms, for the sake
@@ -422,92 +412,102 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
              & a_err=ch_err)
         goto 9999
       endif
-      exit array_build_loop
+!!$      write(0,*) ' Early exit  of array_build_loop',i,iszv,info,&
+      level = newsz
+      stop_hierarchy_loop = .true. 
     else
-      if (do_timings) call psb_tic(idx_matasb)            
+      if (do_timings) call psb_tic(idx_matasb)
       if (info == psb_success_) call prec%precv(i)%mat_asb(&
            & prec%precv(i-1)%base_a,prec%precv(i-1)%base_desc,&
            & ilaggr,nlaggr,op_prol,info)
       if (do_timings) call psb_toc(idx_matasb)      
+      level = i
     end if
+
+    !
+    ! Do we want to remap onto a smaller subset of processes?
+    ! Will need a more sophisticated policy
+    !
+    block
+      type(psb_ctxt_type) :: lctxt
+      integer(psb_ipk_)   :: lme,lnp
+      lctxt = prec%precv(level)%desc_ac%get_ctxt()
+      call psb_info(lctxt,lme,lnp)
+      if (amg_z_policy_do_remap(lctxt,level,sum(nlaggr))) then 
+!!$        write(0,*) ' Context on remapping ',lme,lnp
+        if ((lme >=0).and.(lnp>=2)) then 
+          associate(lv=>prec%precv(level), rmp => prec%precv(level)%remap_data)
+            call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
+            call lv%ac%clone(rmp%ac_pre_remap,info)
+!!$            write(0,*) 'During first remapping desc_ac:',lv%desc_ac%is_asb(),&
+!!$                 & rmp%desc_ac_pre_remap%is_asb()
+!!$            write(0,*) ' First Doing remapping ',lnp, lnp/2
+            call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
+                 & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
+!!$        write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
+!!$             & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
+!!$            write(0,*) 'First Assignment ',size(lv%linmap%naggr),size(rmp%naggr)
+            lv%linmap%naggr(:) =  rmp%naggr(:)
+            lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
+            lv%base_a          => lv%ac
+            lv%base_desc       => lv%desc_ac
+            block
+              integer(psb_ipk_) :: meu,npu,mev,npv
+              type(psb_ctxt_type) :: ct
+              ct = lv%linmap%p_desc_U%get_ctxt()
+              call psb_info(ct,meu,npu)
+              ct = lv%linmap%p_desc_V%get_ctxt()
+              call psb_info(ct,mev,npv)
+!!$              write(0,*) 'First Check on out remapping ',i,&
+!!$                   & rmp%desc_ac_pre_remap%is_asb(),&
+!!$                   & ':',meu,npu,mev,npv
+            end block
+          end associate
+        end if
+!!$        write(0,*) 'Second Check on out remapping ',level,&
+!!$             & prec%precv(level)%remap_data%desc_ac_pre_remap%is_asb(), newsz
+      end if
+    end block
+
     if (info /= psb_success_) then 
       write(ch_err,'(a,i7)') 'Mat asb fail @ level ',i
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err=ch_err)
       goto 9999
     endif
-    if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
-
+    if (stop_hierarchy_loop) then
+      exit array_build_loop
+    else
+      if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
+    end if
   end do array_build_loop
 
-  if (newsz > 0) then
-    !
-    ! We exited early from the build loop, need to fix
-    ! the size.
-    !
-    allocate(tprecv(newsz),stat=info)
-    if (info /= psb_success_) then 
-      call psb_errpush(psb_err_from_subroutine_,name,&
-           & a_err='prec reallocation')
-      goto 9999
-    endif
-    do i=1,newsz
-      call prec%precv(i)%move_alloc(tprecv(i),info)
-    end do
-    do i=newsz+1, iszv
-      call prec%precv(i)%free(info)
-    end do
-    call move_alloc(tprecv,prec%precv) 
-    ! Ignore errors from transfer
-    info = psb_success_
-    !
-    ! Restart
-    iszv = newsz
-    ! Fix the pointers, but the level 1 should
-    ! be treated differently
-    if (.not.associated(prec%precv(1)%base_a,a)) then
-      prec%precv(1)%base_a => prec%precv(1)%ac
-    end if
-    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
-      prec%precv(i)%base_a       => prec%precv(i)%ac
-      prec%precv(i)%base_desc    => prec%precv(i)%desc_ac
-      ! 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
+!!$  write(0,*) ' Done  array_build_loop',iszv,newsz,info,psb_errstatus_fatal()
+
+  if (newsz>0) then
+!!$    do i=2,newsz
+!!$      write(0,*) me,'Newsz Out of array_build_loop ',i,':',&
+!!$           & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$    end do
+!!$    write(0,*) 'Calling set_nlevs ',newsz
+    call prec%set_nlevs(newsz)
+  else
+!!$    do i=2, iszv
+!!$      write(0,*) me,'Out of array_build_loop ',i,':',&
+!!$           & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$    end do
   end if
+  iszv = prec%get_nlevs()
+  call psb_barrier(ctxt)
 
 
-  !write(0,*) 'Should we remap? '
-  if (amg_get_do_remap().and.(np>=4)) then
-    write(0,*) 'Going for remapping '
-    if (.true.) then 
-      associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
-        call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
-        call lv%ac%clone(rmp%ac_pre_remap,info)
-        if (np >= 8) then 
-          call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
-               & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
-        else
-          call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
-               & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
-        end if
-        write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
-             & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
-        lv%linmap%naggr(:)    =  rmp%naggr(:)
-        lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
-        lv%base_a          => lv%ac
-        lv%base_desc       => lv%desc_ac
-      end associate
-    end if
-  end if
+!!$  write(0,*) ' Done  reallocating precv',iszv,newsz,info
+!!$
+!!$  do i=2, iszv
+!!$    write(0,*) me,'At end of hierarchy_bld level',i,':',&
+!!$         & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
+!!$  end do
+  call psb_barrier(ctxt)
 
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
@@ -515,8 +515,9 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   endif
 
-  iszv = size(prec%precv)
-
+  iszv = prec%get_nlevs()
+!!$  write(0,*) 'Going for cmp_complexity ',&
+!!$       & allocated(prec%precv),iszv,size(prec%precv)
   call prec%cmp_complexity()
   call prec%cmp_avg_cr()
 
@@ -656,4 +657,49 @@ contains
     return
   end subroutine restore_smoothers
 #endif
+
+  function amg_z_policy_do_remap(ctxt,level,aggsize) result(res)
+    logical :: res
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_) :: level
+    integer(psb_lpk_) :: aggsize
+    res =  amg_get_do_remap().and.(level>=2)
+!!$    res = .false.
+  end function amg_z_policy_do_remap
+
+  subroutine amg_z_hierarchy_bld_cmp_newsz(level,iszv,prevsize,&
+       & nlaggr,casize,mnratio,sizeratio,newsz)
+    implicit none 
+    integer(psb_ipk_) :: level,iszv,newsz
+    integer(psb_lpk_) :: nlaggr(:)
+    integer(psb_lpk_) :: prevsize, casize
+    real(psb_dpk_)    :: mnratio, sizeratio
+    ! ==============================
+    integer(psb_lpk_) :: iaggsize
+
+    newsz    = 0 
+    iaggsize = sum(nlaggr)
+    sizeratio = prevsize
+    sizeratio = sizeratio/iaggsize
+!!$    write(0,*) 'From cmp_newsz: ',iaggsize,casize,&
+!!$         & sizeratio,mnratio, level
+
+    if (iaggsize <= casize) newsz = level      
+    if (level == iszv)      newsz = level
+
+    if (level>2) then
+      if (sizeratio < mnratio) then
+        if (sizeratio > 1) then
+          newsz = level
+        else
+          !
+          ! We are not gaining 
+          !
+          newsz = level-1
+        end if
+      end if
+    end if
+!!$    write(0,*) 'At end of cmp_newsz ',newsz
+  end subroutine amg_z_hierarchy_bld_cmp_newsz
+
 end subroutine amg_z_hierarchy_bld

amgprec/impl/amg_z_smoothers_bld.f90

@@ -136,9 +136,9 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
   !
   ! Check to ensure all procs have the same
   !
-  iszv       = size(prec%precv)
+  iszv       = prec%get_nlevs()
   call psb_bcast(ctxt,iszv)
-  if (iszv /= size(prec%precv)) then
+  if (iszv /= prec%get_nlevs()) then
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999

amgprec/impl/amg_zfile_prec_descr.f90

@@ -136,7 +136,7 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
       ! ensured by amg_precbld).
       !
       if (me == root_) then
-        nlev = size(prec%precv)
+        nlev = prec%get_nlevs()
         do ilev = 1, nlev 
           if (.not.allocated(prec%precv(ilev)%sm)) then 
             info = 3111
@@ -152,7 +152,7 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
         write(iout_,*) trim(prefix_),' Base matrix      : ',&
              & gl_nrows, gl_ncols, gl_nzeros
         write(iout_,*)
-        
+        write(iout_,*) 'At level :',1,' we have ',np,' processes'
         if (nlev == 1) then
           !
           ! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.

amgprec/impl/amg_zmlprec_aply.f90

@@ -207,6 +207,7 @@ subroutine amg_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
 
   use psb_base_mod
   use amg_base_prec_type
+  use amg_prec_mod
   use amg_z_inner_mod, amg_protect_name => amg_zmlprec_aply_vect
 
   implicit none
@@ -243,10 +244,10 @@ subroutine amg_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
 
   if (debug_level >= psb_debug_inner_) &
        & write(debug_unit,*) me,' ',trim(name),&
-       & ' Entry  ', size(p%precv)
+       & ' Entry  ', p%get_nlevs()
 
   trans_ = psb_toupper(trans)
-  nlev   = size(p%precv)
+  nlev   = p%get_nlevs()
 
   do_alloc_wrk = .not.allocated(p%precv(1)%wrk)
 
@@ -381,7 +382,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_ml')
@@ -393,39 +394,38 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
     end if
-    if (me >= 0) then
-      select case(p%precv(level)%parms%ml_cycle) 
-        
-      case(amg_no_ml_)
-        !
-        ! No preconditioning, should not really get here
-        ! 
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='amg_no_ml_ in mlprc_aply?')
-        goto 9999      
-        
-      case(amg_add_ml_)
-        
-        call amg_z_inner_add(p, level, trans, work)
-        
-      case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
-        
-        call amg_z_inner_mult(p, level, trans, work)
-        
-      case(amg_kcycle_ml_, amg_kcyclesym_ml_)
-        
-        call amg_z_inner_k_cycle(p, level, trans, work)
-        
-      case default
-        info = psb_err_from_subroutine_ai_
-        call psb_errpush(info,name,a_err='invalid ml_cycle',&
-             &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
-        goto 9999      
-        
-      end select
-      if(debug_level > 1) then
-        write(debug_unit,*) me,' End inner_ml_aply at level ',level
-      end if
+    
+    select case(p%precv(level)%parms%ml_cycle) 
+      
+    case(amg_no_ml_)
+      !
+      ! No preconditioning, should not really get here
+      ! 
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='amg_no_ml_ in mlprc_aply?')
+      goto 9999      
+      
+    case(amg_add_ml_)
+      
+      call amg_z_inner_add(p, level, trans, work)
+      
+    case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
+      
+      call amg_z_inner_mult(p, level, trans, work)
+      
+    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
+      
+      call amg_z_inner_k_cycle(p, level, trans, work)
+      
+    case default
+      info = psb_err_from_subroutine_ai_
+      call psb_errpush(info,name,a_err='invalid ml_cycle',&
+           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
+      goto 9999      
+      
+    end select
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' End inner_ml_aply at level ',level
     end if
 
     call psb_erractionrestore(err_act)
@@ -468,7 +468,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_add')
@@ -492,12 +492,13 @@ contains
          & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
          & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
          & wv => p%precv(level)%wrk%wv)
-
+      
       if (me >= 0) then 
         if (allocated(p%precv(level)%sm2a)) then
           call psb_geaxpby(zone,vx2l,zzero,vy2l,base_desc,info)
           
-          sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
+          sweeps = max(p%precv(level)%parms%sweeps_pre,&
+               & p%precv(level)%parms%sweeps_post)
           do k=1, sweeps
             call p%precv(level)%sm%apply(zone,&
                  & vy2l,zzero,vty,&
@@ -509,7 +510,6 @@ contains
                  & base_desc, trans,&
                  & ione,work,wv,info,init='Z')        
           end do
-          
         else
           sweeps = p%precv(level)%parms%sweeps_pre
           call p%precv(level)%sm%apply(zone,&
@@ -523,40 +523,37 @@ contains
              & a_err='Error during ADD smoother_apply')
         goto 9999
       end if
-
+      
       if (level < nlev) then
         ! Apply the restriction
         call p%precv(level+1)%map_rstr(zone,vx2l,&
              & zzero,p%precv(level+1)%wrk%vx2l,&
-             & info,work=work,&
-             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+             & info,work=work,vtx=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during restriction')
           goto 9999
         end if
-
+        
         call inner_ml_aply(level+1,p,trans,work,info)
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error in recursive call')
           goto 9999
         end if
-
+        
         !
         ! Apply the prolongator
         !  
         call p%precv(level+1)%map_prol(zone,&
              & p%precv(level+1)%wrk%vy2l, zone,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work, vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
           goto 9999
         end if
-
-
+        
       end if
     end associate
     
@@ -597,7 +594,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_mult')
@@ -608,7 +605,7 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' inner_mult at level ',level
     end if
-
+!!$    write(debug_unit,*) me,' inner_mult at level (1):',level,np
     sweeps_post = p%precv(level)%parms%sweeps_post
     sweeps_pre  = p%precv(level)%parms%sweeps_pre
     pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
@@ -618,6 +615,10 @@ contains
          & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
          & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
          & wv => p%precv(level)%wrk%wv)
+!!$      write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',&
+!!$           & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv)
+      if (me >=0) then
+      
       if (level < nlev) then 
         !
         ! Apply the first smoother
@@ -625,7 +626,6 @@ contains
         !
 
         if (pre) then
-          if (me >=0) then
 !!$            write(0,*) me,'Applying smoother pre ', level
             if (trans == 'N') then 
               sweeps = p%precv(level)%parms%sweeps_pre
@@ -644,28 +644,29 @@ contains
                    & a_err='Error during PRE smoother_apply')
               goto 9999
             end if
-          end if
-        endif
+      
+          endif
         !
         ! Compute the residual for next level and call recursively
         !
         if (pre) then
-          call psb_geaxpby(zone,vx2l,&
-               & zzero,vty,&
-               & base_desc,info)
-
-          if (info == psb_success_) call psb_spmm(-zone,base_a,&
-               & vy2l,zone,vty,&
-               & base_desc,info,work=work,trans=trans)
-          if (info /= psb_success_) then
-            call psb_errpush(psb_err_internal_error_,name,&
-                 & a_err='Error during residue')
-            goto 9999
-          end if
+            
+            call psb_geaxpby(zone,vx2l,&
+                 & zzero,vty,&
+                 & base_desc,info)
+            
+            if (info == psb_success_) call psb_spmm(-zone,base_a,&
+                 & vy2l,zone,vty,&
+                 & base_desc,info,work=work,trans=trans)
+            if (info /= psb_success_) then
+              call psb_errpush(psb_err_internal_error_,name,&
+                   & a_err='Error during residue')
+              goto 9999
+            end if
+          
           call p%precv(level+1)%map_rstr(zone,vty,&
                & zzero,p%precv(level+1)%wrk%vx2l,&
-               & info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & info,work=work,vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -675,8 +676,7 @@ contains
           ! Shortcut: just transfer x2l. 
           call p%precv(level+1)%map_rstr(zone,vx2l,&
                & zzero,p%precv(level+1)%wrk%vx2l,&
-               & info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & info,work=work,vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -691,8 +691,7 @@ contains
         !  
         call p%precv(level+1)%map_prol(zone,&
              & p%precv(level+1)%wrk%vy2l,zone,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work,vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
@@ -701,17 +700,17 @@ contains
 
         if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
 
-          if (me >=0) then 
+          
             call psb_geaxpby(zone,vx2l, zzero,vty,&
                  & base_desc,info)        
             if (info == psb_success_) call psb_spmm(-zone,base_a,&
                  & vy2l,zone,vty,&
                  & base_desc,info,work=work,trans=trans)
-          end if
+          
           if (info == psb_success_) &
                & call p%precv(level+1)%map_rstr(zone,vty,&
                & zzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
-               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+               & vtx=wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during W-cycle restriction')
@@ -722,8 +721,7 @@ contains
 
           if (info == psb_success_) call p%precv(level+1)%map_prol(zone, &
                & p%precv(level+1)%wrk%vy2l,zone,vy2l,&
-               & info,work=work,&
-               & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+               & info,work=work,vty=wv(1))
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -735,7 +733,7 @@ contains
 
 
         if (post) then
-          if (me >=0) then 
+          
             call psb_geaxpby(zone,vx2l,&
                  & zzero,vty,&
                  & base_desc,info)
@@ -762,7 +760,7 @@ contains
                    & vty,zone,vy2l, base_desc, trans,&
                    & sweeps,work,wv,info,init='Z')
             end if
-          end if
+          
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -789,6 +787,7 @@ contains
              & a_err='Invalid LEVEL vs NLEV')
         goto 9999
       end if
+    end if
     end associate
 9998 continue
     call psb_erractionrestore(err_act)
@@ -833,7 +832,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
+    nlev = p%get_nlevs()
     if ((level < 1) .or. (level > nlev)) then
       call psb_errpush(psb_err_internal_error_,name,&
            & a_err='wrong call level to inner_add')
@@ -910,7 +909,7 @@ contains
         call  p%precv(level + 1)%map_rstr(zone,vty,&
              & zzero,p%precv(level + 1)%wrk%vx2l,&
              &info,work=work,&
-             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
+             & vtx=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -945,8 +944,7 @@ contains
         !  
         call p%precv(level+1)%map_prol(zone,&
              & p%precv(level+1)%wrk%vy2l,zone,vy2l,&
-             & info,work=work,&
-             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
+             & info,work=work,vty=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -1007,9 +1005,6 @@ contains
   end subroutine amg_z_inner_k_cycle
   
   recursive subroutine amg_zinneritkcycle(p, level, trans, work, innersolv)
-    use psb_base_mod
-    use amg_prec_mod
-    use amg_z_inner_mod, amg_protect_name => amg_zmlprec_aply
 
     implicit none
 
@@ -1161,532 +1156,3 @@ contains
 
 end subroutine amg_zmlprec_aply_vect
 
-
-!
-! Old routine for arrays instead of psb_X_vector. To be deleted eventually.
-!
-!
-subroutine amg_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
-
-  use psb_base_mod
-  use amg_base_prec_type
-  use amg_z_inner_mod, amg_protect_name => amg_zmlprec_aply
-
-  implicit none
-
-  ! Arguments
-  type(psb_desc_type),intent(in)    :: desc_data
-  type(amg_zprec_type), intent(inout)  :: p
-  complex(psb_dpk_),intent(in)         :: alpha,beta
-  complex(psb_dpk_),intent(inout)      :: x(:)
-  complex(psb_dpk_),intent(inout)      :: y(:)
-  character, intent(in)             :: trans
-  complex(psb_dpk_),target             :: work(:)
-  integer(psb_ipk_), intent(out)              :: info
-
-  ! Local variables
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: np, me
-  integer(psb_ipk_)   :: err_act
-  integer(psb_ipk_)   :: debug_level, debug_unit, nlev,nc2l,nr2l,level
-  character(len=20)   :: name
-  character           :: trans_
-  type amg_mlwrk_type
-    complex(psb_dpk_), allocatable  :: tx(:), ty(:), x2l(:), y2l(:)
-  end type amg_mlwrk_type
-  type(amg_mlwrk_type), allocatable, target  :: mlwrk(:)
-
-  name='amg_zmlprec_aply'
-  info = psb_success_
-  call psb_erractionsave(err_act)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-
-  ctxt = desc_data%get_context()
-  call psb_info(ctxt, me, np)
-
-  if (debug_level >= psb_debug_inner_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & ' Entry  ', size(p%precv)
-
-  trans_ = psb_toupper(trans)
-
-  nlev = size(p%precv)
-  allocate(mlwrk(nlev),stat=info) 
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
-    goto 9999      
-  end if
-  level = 1
-
-  do level = 1, nlev
-    call psb_geasb(mlwrk(level)%x2l,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%y2l,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%tx,&
-         & p%precv(level)%base_desc,info)
-    call psb_geasb(mlwrk(level)%ty,&
-         & p%precv(level)%base_desc,info)
-    if (psb_errstatus_fatal()) then 
-      nc2l = p%precv(level)%base_desc%get_local_cols()
-      info=psb_err_alloc_request_
-      call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
-           & a_err='complex(psb_dpk_)')
-      goto 9999      
-    end if
-  end do
-
-  mlwrk(level)%x2l(:) = x(:) 
-  mlwrk(level)%y2l(:) = zzero 
-
-  call inner_ml_aply(level,p,mlwrk,trans_,work,info)    
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,&
-         & a_err='Inner prec aply')
-    goto 9999
-  end if
-
-  call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,&
-       &   p%precv(level)%base_desc,info)
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,&
-         & a_err='Error final update')
-    goto 9999
-  end if
-
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-
-contains
-
-    !
-  !
-  ! inner_ml_aply: apply AMG at a given level.
-  ! This routine dispatches the computation according to the type
-  ! specified at the current level.
-  ! Each of the corrections will inturn call recursively this routine.
-  !
-  ! Assumptions:
-  ! On input:
-  !   mlprec_wkr(level)%vx2l   contains the input vector (RHS)
-  !   mlprec_wkr(level)%vy2l   contains the initial guess
-  !
-  ! On output:
-  !   mlprec_wkr(level)%vy2l   contains the solution
-  !
-  ! Constraints: each of the called routines must properly handle
-  ! the input/output conditions for level+1 (i.e. apply
-  ! prolongation/restriction).
-  ! Note: for historical/convenience reasons the prolongator/restrictor
-  ! between level and level+1 are stored at level+1. 
-  !
-  !
-  recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info)    
-
-    implicit none 
-
-    ! Arguments
-    integer(psb_ipk_)                           :: level 
-    type(amg_zprec_type), target, intent(inout) :: p
-    type(amg_mlwrk_type), intent(inout), target    :: mlwrk(:)
-    character, intent(in)                       :: trans
-    complex(psb_dpk_),target                      :: work(:)
-    integer(psb_ipk_), intent(out)              :: info
-
-    type(psb_z_vect_type) :: res
-    type(psb_z_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_ml_aply'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_ml')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_ml_aply at level ',level
-    end if
-
-    select case(p%precv(level)%parms%ml_cycle) 
-
-    case(amg_no_ml_)
-      !
-      ! No preconditioning, should not really get here
-      ! 
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='amg_no_ml_ in mlprc_aply?')
-      goto 9999      
-
-    case(amg_add_ml_)
-
-      call amg_z_inner_add(p, mlwrk, level, trans, work)
-
-    case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_)
-
-      call amg_z_inner_mult(p, mlwrk, level, trans, work)
-      
-! !$    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
-! !$
-! !$      call amg_z_inner_k_cycle(p, mlwrk, level, trans, work)
-      
-    case default
-      info = psb_err_from_subroutine_ai_
-      call psb_errpush(info,name,a_err='invalid ml_cycle',&
-           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
-      goto 9999      
-
-    end select
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine inner_ml_aply
-
-
-  recursive subroutine amg_z_inner_add(p, mlwrk, level, trans, work)
-    use psb_base_mod
-    use amg_prec_mod
-
-    implicit none
-
-    !Input/Oputput variables
-    type(amg_zprec_type), intent(inout)  :: p
-
-    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
-    integer(psb_ipk_), intent(in) :: level
-    character, intent(in)             :: trans
-    complex(psb_dpk_),target            :: work(:)
-    type(psb_z_vect_type) :: res
-    type(psb_z_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_inner_add'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_add')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_add at level ',level
-    end if
-
-    if ((level<1).or.(level>nlev)) then
-      info = psb_err_internal_error_ 
-      call psb_errpush(info,name,&
-           & a_err='Invalid LEVEL>NLEV')
-      goto 9999
-    end if
-    
-    sweeps = p%precv(level)%parms%sweeps_pre
-    call p%precv(level)%sm%apply(zone,&
-         & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,&
-         & p%precv(level)%base_desc, trans,&
-         & sweeps,work,info)
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Error during ADD smoother_apply')
-      goto 9999
-    end if
-
-    if (level < nlev) then
-      ! Apply the restriction
-      call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,&
-           & zzero,mlwrk(level+1)%x2l,&
-           & info,work=work)
-      mlwrk(level+1)%y2l(:) = zzero
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during restriction')
-        goto 9999
-      end if
-      
-      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error in recursive call')
-        goto 9999
-      end if
-
-      !
-      ! Apply the prolongator and add correction.
-      !  
-      call p%precv(level+1)%map_prol(zone,&
-           & mlwrk(level+1)%y2l,zone,mlwrk(level)%y2l,&
-           & info,work=work)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during prolongation')
-        goto 9999
-      end if
-
-
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine amg_z_inner_add
-
-  recursive subroutine amg_z_inner_mult(p, mlwrk, level, trans, work)
-    use psb_base_mod
-    use amg_prec_mod
-
-    implicit none
-
-    !Input/Oputput variables
-    type(amg_zprec_type), intent(inout)  :: p
-
-    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
-    integer(psb_ipk_), intent(in) :: level
-    character, intent(in)             :: trans
-    complex(psb_dpk_),target            :: work(:)
-    type(psb_z_vect_type) :: res
-    type(psb_z_vect_type), pointer :: current
-    integer(psb_ipk_) :: sweeps_post, sweeps_pre
-    ! Local variables
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: np, me
-    integer(psb_ipk_)   :: i, err_act
-    integer(psb_ipk_)   :: debug_level, debug_unit
-    integer(psb_ipk_)   :: nlev, ilev, sweeps
-    logical             :: pre, post
-    character(len=20)   :: name
-
-
-
-    name = 'inner_inner_mult'
-    info = psb_success_
-    call psb_erractionsave(err_act)
-    debug_unit  = psb_get_debug_unit()
-    debug_level = psb_get_debug_level()
-    nlev = size(p%precv)
-    if ((level < 1) .or. (level > nlev)) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong call level to inner_mult')
-      goto 9999      
-    end if
-    ctxt = p%precv(level)%base_desc%get_context()
-    call psb_info(ctxt, me, np)
-
-    if(debug_level > 1) then
-      write(debug_unit,*) me,' inner_mult at level ',level
-    end if
-
-    if ((level < nlev).or.(nlev == 1)) then
-      sweeps_post = p%precv(level)%parms%sweeps_post
-      sweeps_pre  = p%precv(level)%parms%sweeps_pre
-    else
-      sweeps_post = p%precv(level-1)%parms%sweeps_post
-      sweeps_pre  = p%precv(level-1)%parms%sweeps_pre
-    endif
-
-    pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
-    post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N'))
-
-    
-    if (level < nlev) then 
-
-      !
-      ! Apply the first smoother
-      !
-
-      if (pre) then
-        if (trans == 'N') then 
-          sweeps = p%precv(level)%parms%sweeps_pre
-          if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
-               & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Y')
-        else
-          sweeps = p%precv(level)%parms%sweeps_post
-          if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
-               & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Y')
-        end if
-        
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during PRE smoother_apply')
-          goto 9999
-        end if
-      endif
-
-      !
-      ! Compute the residual and call recursively
-      !
-      if (pre) then
-        call psb_geaxpby(zone,mlwrk(level)%x2l,&
-             & zzero,mlwrk(level)%ty,&
-             & p%precv(level)%base_desc,info)
-        
-        if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,&
-             & mlwrk(level)%y2l,zone,mlwrk(level)%ty,&
-             & p%precv(level)%base_desc,info,work=work,trans=trans)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during residue')
-          goto 9999
-        end if
-        call p%precv(level+1)%map_rstr(zone,mlwrk(level)%ty,&
-             & zzero,mlwrk(level+1)%x2l,info,work=work)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during restriction')
-          goto 9999
-        end if
-      else
-        ! Shortcut: just transfer x2l. 
-        call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,&
-             & zzero,mlwrk(level+1)%x2l,info,work=work)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during restriction')
-          goto 9999
-        end if
-      endif
-      ! First guess is zero
-      mlwrk(level+1)%y2l(:) = zzero
-      
-      
-      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      
-      if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
-        ! On second call will use output y2l as initial guess
-        if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
-      endif
-      
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error in recursive call')
-        goto 9999
-      end if
-      
-      
-      !
-      ! Apply the prolongator
-      !  
-      call p%precv(level+1)%map_prol(zone,mlwrk(level+1)%y2l,&
-           & zone,mlwrk(level)%y2l,info,work=work)
-      if (info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Error during prolongation')
-        goto 9999
-      end if
-      
-      !
-      ! Compute the residual
-      !
-      if (post) then
-        call psb_geaxpby(zone,mlwrk(level)%x2l,&
-             & zzero,mlwrk(level)%tx,&
-             & p%precv(level)%base_desc,info)
-        call psb_spmm(-zone,p%precv(level)%base_a,mlwrk(level)%y2l,&
-             & zone,mlwrk(level)%tx,p%precv(level)%base_desc,info,&
-             & work=work,trans=trans)
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during residue')
-          goto 9999
-        end if
-        !
-        ! Apply the second smoother
-        !
-        if (trans == 'N') then
-          sweeps = p%precv(level)%parms%sweeps_post
-          if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
-               & mlwrk(level)%tx,zone,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Z')
-        else 
-          sweeps = p%precv(level)%parms%sweeps_pre
-          if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
-               & mlwrk(level)%tx,zone,mlwrk(level)%y2l,&
-               & p%precv(level)%base_desc, trans,&
-               & sweeps,work,info,init='Z')
-        end if
-        
-        if (info /= psb_success_) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='Error during POST smoother_apply')
-          goto 9999
-        end if
-        
-      endif            
-      
-    else if (level == nlev) then
-      
-      sweeps = p%precv(level)%parms%sweeps_pre
-      if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
-           & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,&
-           & p%precv(level)%base_desc, trans,&
-           & sweeps,work,info)
-
-    else
-
-      info = psb_err_internal_error_ 
-      call psb_errpush(info,name,&
-           & a_err='Invalid LEVEL vs NLEV')
-      goto 9999
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 call psb_error_handler(err_act)
-    return
-
-  end subroutine amg_z_inner_mult
-    
-
-end subroutine amg_zmlprec_aply

amgprec/impl/amg_zmlprec_aply_a.f90

@@ -0,0 +1,733 @@
+!  
+!   
+!                             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 prior written permission.
+!   
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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_zmlprec_aply.f90
+!
+! Subroutine: amg_zmlprec_aply
+! Version:    real
+!
+!  Current version of this file contributed by:
+!        Ambra Abdullahi Hassan 
+!
+!
+!  This routine computes
+!  
+!                        Y = beta*Y + alpha*op(ML^(-1))*X,
+!  where 
+!  - ML is a multilevel preconditioner associated with
+!    a certain matrix A and stored in p,
+!  - op(ML^(-1)) is ML^(-1) or its transpose, according to the value of trans,
+!  - X and Y are vectors,
+!  - alpha and beta are scalars.
+!
+!  The following multilevel strategies can be applied:
+!
+!  - Additive multilevel Schwarz,
+!  - classical V-cycle,
+!  - classical W-cycle,
+!  - K-cycle both for symmetric and nonsymmetric matrices, where 2 iterations
+!    of FCG(1) or GCR, respectively, are applied at each level
+!    except the coarsest.
+!
+!  For each level we have as many submatrices as processes (except for the coarsest
+!  level where we might have a replicated index space) and each process takes care
+!  of one submatrix.
+!
+!  A multilevel preconditioner is regarded as an array of 'one-level' data structures,
+!  each containing the part of the preconditioner associated to a certain level
+!  (for more details see the description of amg_Tonelev_type in amg_prec_type.f90).
+!  For each level lev, there is a smoother stored in
+!     p%precv(lev)%sm
+!  which in turn contains a solver
+!     p$precv(lev)%sm%sv
+!  Typically the solver acts only locally, and the smoother applies any required
+!  parallel communication/action. 
+!  Each level has  a matrix A(lev), obtained by 'tranferring' the original
+!  matrix A (i.e. the matrix to be preconditioned) to the level lev, through smoothed
+!  aggregation.
+!
+!  The levels are numbered in increasing order starting from the finest one, i.e.
+!  level 1 is the finest level and A(1) is the matrix A.
+!
+!  This routine is formulated in a recursive way, so it is quite compact.
+!
+!  The V-cycle can be described as follows, where
+!  P(lev) denotes the smoothed prolongator from level lev to level
+!  lev-1, while R(lev) denotes the corresponding  restriction operator
+!  (normally its transpose) from level lev-1 to level lev.
+!  M(lev) is the smoother at the current level.
+!
+!
+!   1. Transfer the outer vector Xest to u(1) (inner X at level 1)
+!
+!   2. Invoke V-cycle(1,M,P,R,A,b,u)
+!
+!    procedure V-cycle(lev,M,P,R,A,b,u)
+!
+!      if (lev < nlev) then
+!
+!         u(lev)   = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev))
+!
+!         b(lev+1) = R(lev+1)*(b(lev)-A(lev)*u(lev))
+!
+!         u(lev+1) = V-cycle(lev+1,M,P,R,A,b,u)
+!
+!         u(lev)   = u(lev) + P(lev+1) * u(lev+1)
+!
+!         u(lev)   = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev))
+!
+!      else
+!
+!         solve  A(lev)*u(lev) = b(lev)
+!
+!      end if
+!
+!      return u(lev)
+!    end
+!
+!   3. Transfer u(1) to the external:
+!         Yext = beta*Yext + alpha*u(1)
+!
+!
+!  In the implementation, the recursive procedure is inner_ml_aply, which
+!  in turn uses amg_inner_add (for additive multilevel),
+!  amg_inner_mult (for V-cycle and W-cycle), and
+!  amg_inner_k_cycle (for symmetric and non-symmetric K-cycle).
+!  
+!  For a detailed description of the algorithms, see:
+!
+!  - B.F. Smith, P.E. Bjorstad, W.D. Gropp,
+!    Domain decomposition: parallel multilevel methods for elliptic partial
+!    differential equations, Cambridge University Press, 1996.
+!
+!  - W. L. Briggs, V. E. Henson, S. F.  McCormick,
+!    A Multigrid Tutorial, Second Edition
+!    SIAM, 2000.
+!
+!  - K. Stuben,
+!    An Introduction to Algebraic Multigrid,
+!    in A. Schuller, U. Trottenberg, C. Oosterlee, Multigrid, Academic Press, 2001.
+!
+!  - Y. Notay, P. S. Vassilevski,
+!    Recursive Krylov-based multigrid cycles
+!    Numerical Linear Algebra with Applications, 15 (5), 2008, 473--487.
+!
+!
+! Arguments:
+!   alpha      -   complex(psb_dpk_), input.
+!                  The scalar alpha.
+!   p          -   type(amg_zprec_type), input.
+!                  The multilevel preconditioner data structure containing the
+!                  local part of the preconditioner to be applied.
+!      Note that nlev = size(p%precv) = number of levels.
+!      p%precv(lev)%sm        -  type(psb_zbaseprec_type)
+!                                 The pre-'smoother' for the current level
+!      p%precv(lev)%sm2       -  type(psb_zbaseprec_type)
+!                                 The post-'smoother' for the current level
+!                                 may be the same or different from %sm
+!      p%precv(lev)%ac        -  type(psb_zspmat_type) 
+!                                 The local part of the matrix A(lev).
+!      p%precv(lev)%parms     -  type(psb_dml_parms) 
+!                                 Parameters controllin the multilevel prec. 
+!      p%precv(lev)%desc_ac   -  type(psb_desc_type).
+!                                 The communication descriptor associated to the sparse
+!                                 matrix A(lev)
+!      p%precv(lev)%map       -  type(psb_inter_desc_type)
+!                                 Stores the linear operators mapping level (lev-1)
+!                                 to (lev) and vice versa. These are the restriction
+!                                 and prolongation operators described in the sequel. 
+!      p%precv(lev)%base_a    -  type(psb_zspmat_type), pointer.
+!                                 Pointer (really a pointer!) to the base matrix of
+!                                 the current level, i.e. the local part of A(lev);
+!                                 so we have a unified treatment of residuals. We
+!                                 need this to avoid passing explicitly the matrix
+!                                 A(lev) to the routine which applies the
+!                                 preconditioner.
+!      p%precv(lev)%base_desc -  type(psb_desc_type), pointer.
+!                                 Pointer to the communication descriptor associated
+!                                 to the sparse matrix pointed by base_a.  
+!                  
+!   x          -  complex(psb_dpk_), dimension(:), input.
+!                 The local part of the vector X.
+!   beta       -  complex(psb_dpk_), input.
+!                 The scalar beta.
+!   y          -  complex(psb_dpk_), dimension(:), input/output.
+!                 The local part of the vector Y.
+!   desc_data  -  type(psb_desc_type), input.
+!                 The communication descriptor associated to the matrix to be
+!                 preconditioned.
+!   trans      -  character, optional.
+!                 If trans='N','n' then op(M^(-1)) = M^(-1);
+!                 if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)).
+!   work       -  complex(psb_dpk_), dimension (:), optional, target.
+!                 Workspace. Its size must be at least 4*desc_data%get_local_cols().
+!   info       -  integer, output.
+!                 Error code.
+!
+!   Note that when the LU factorization of the matrix A(lev) is computed instead of
+!   the ILU one, by using UMFPACK or SuperLU or MUMPS, the corresponding
+!   L and U factors are stored in data structures handled
+!   by the third party software. 
+!
+
+!
+! Old routine for arrays instead of psb_X_vector. To be deleted eventually.
+!
+!
+subroutine amg_zmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info)
+
+  use psb_base_mod
+  use amg_base_prec_type
+  use amg_z_inner_mod, amg_protect_name => amg_zmlprec_aply_a
+
+  implicit none
+
+  ! Arguments
+  type(psb_desc_type),intent(in)    :: desc_data
+  type(amg_zprec_type), intent(inout)  :: p
+  complex(psb_dpk_),intent(in)         :: alpha,beta
+  complex(psb_dpk_),intent(inout)      :: x(:)
+  complex(psb_dpk_),intent(inout)      :: y(:)
+  character, intent(in)             :: trans
+  complex(psb_dpk_),target             :: work(:)
+  integer(psb_ipk_), intent(out)              :: info
+
+  ! Local variables
+  type(psb_ctxt_type) :: ctxt
+  integer(psb_ipk_)   :: np, me
+  integer(psb_ipk_)   :: err_act
+  integer(psb_ipk_)   :: debug_level, debug_unit, nlev,nc2l,nr2l,level
+  character(len=20)   :: name
+  character           :: trans_
+  type amg_mlwrk_type
+    complex(psb_dpk_), allocatable  :: tx(:), ty(:), x2l(:), y2l(:)
+  end type amg_mlwrk_type
+  type(amg_mlwrk_type), allocatable, target  :: mlwrk(:)
+
+  name='amg_zmlprec_aply'
+  info = psb_success_
+  call psb_erractionsave(err_act)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+
+  ctxt = desc_data%get_context()
+  call psb_info(ctxt, me, np)
+
+  if (debug_level >= psb_debug_inner_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & ' Entry  ', size(p%precv)
+
+  trans_ = psb_toupper(trans)
+
+  nlev = size(p%precv)
+  allocate(mlwrk(nlev),stat=info) 
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
+    goto 9999      
+  end if
+  level = 1
+
+  do level = 1, nlev
+    call psb_geasb(mlwrk(level)%x2l,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%y2l,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%tx,&
+         & p%precv(level)%base_desc,info)
+    call psb_geasb(mlwrk(level)%ty,&
+         & p%precv(level)%base_desc,info)
+    if (psb_errstatus_fatal()) then 
+      nc2l = p%precv(level)%base_desc%get_local_cols()
+      info=psb_err_alloc_request_
+      call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
+           & a_err='complex(psb_dpk_)')
+      goto 9999      
+    end if
+  end do
+
+  mlwrk(level)%x2l(:) = x(:) 
+  mlwrk(level)%y2l(:) = zzero 
+
+  call inner_ml_aply(level,p,mlwrk,trans_,work,info)    
+
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_internal_error_,name,&
+         & a_err='Inner prec aply')
+    goto 9999
+  end if
+
+  call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,&
+       &   p%precv(level)%base_desc,info)
+
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_internal_error_,name,&
+         & a_err='Error final update')
+    goto 9999
+  end if
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+
+contains
+
+    !
+  !
+  ! inner_ml_aply: apply AMG at a given level.
+  ! This routine dispatches the computation according to the type
+  ! specified at the current level.
+  ! Each of the corrections will inturn call recursively this routine.
+  !
+  ! Assumptions:
+  ! On input:
+  !   mlprec_wkr(level)%vx2l   contains the input vector (RHS)
+  !   mlprec_wkr(level)%vy2l   contains the initial guess
+  !
+  ! On output:
+  !   mlprec_wkr(level)%vy2l   contains the solution
+  !
+  ! Constraints: each of the called routines must properly handle
+  ! the input/output conditions for level+1 (i.e. apply
+  ! prolongation/restriction).
+  ! Note: for historical/convenience reasons the prolongator/restrictor
+  ! between level and level+1 are stored at level+1. 
+  !
+  !
+  recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info)    
+
+    implicit none 
+
+    ! Arguments
+    integer(psb_ipk_)                           :: level 
+    type(amg_zprec_type), target, intent(inout) :: p
+    type(amg_mlwrk_type), intent(inout), target    :: mlwrk(:)
+    character, intent(in)                       :: trans
+    complex(psb_dpk_),target                      :: work(:)
+    integer(psb_ipk_), intent(out)              :: info
+
+    type(psb_z_vect_type) :: res
+    type(psb_z_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_ml_aply'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_ml')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_ml_aply at level ',level
+    end if
+
+    select case(p%precv(level)%parms%ml_cycle) 
+
+    case(amg_no_ml_)
+      !
+      ! No preconditioning, should not really get here
+      ! 
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='amg_no_ml_ in mlprc_aply?')
+      goto 9999      
+
+    case(amg_add_ml_)
+
+      call amg_z_inner_add(p, mlwrk, level, trans, work)
+
+    case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_)
+
+      call amg_z_inner_mult(p, mlwrk, level, trans, work)
+      
+! !$    case(amg_kcycle_ml_, amg_kcyclesym_ml_)
+! !$
+! !$      call amg_z_inner_k_cycle(p, mlwrk, level, trans, work)
+      
+    case default
+      info = psb_err_from_subroutine_ai_
+      call psb_errpush(info,name,a_err='invalid ml_cycle',&
+           &  i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
+      goto 9999      
+
+    end select
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine inner_ml_aply
+
+  recursive subroutine amg_z_inner_add(p, mlwrk, level, trans, work)
+    use psb_base_mod
+    use amg_prec_mod
+
+    implicit none
+
+    !Input/Oputput variables
+    type(amg_zprec_type), intent(inout)  :: p
+
+    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
+    integer(psb_ipk_), intent(in) :: level
+    character, intent(in)             :: trans
+    complex(psb_dpk_),target            :: work(:)
+    type(psb_z_vect_type) :: res
+    type(psb_z_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_inner_add'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_add')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_add at level ',level
+    end if
+
+    if ((level<1).or.(level>nlev)) then
+      info = psb_err_internal_error_ 
+      call psb_errpush(info,name,&
+           & a_err='Invalid LEVEL>NLEV')
+      goto 9999
+    end if
+    
+    sweeps = p%precv(level)%parms%sweeps_pre
+    call p%precv(level)%sm%apply(zone,&
+         & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,&
+         & p%precv(level)%base_desc, trans,&
+         & sweeps,work,info)
+    if (info /= psb_success_) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='Error during ADD smoother_apply')
+      goto 9999
+    end if
+
+    if (level < nlev) then
+      ! Apply the restriction
+      call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,&
+           & zzero,mlwrk(level+1)%x2l,&
+           & info,work=work)
+      mlwrk(level+1)%y2l(:) = zzero
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during restriction')
+        goto 9999
+      end if
+      
+      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in recursive call')
+        goto 9999
+      end if
+
+      !
+      ! Apply the prolongator and add correction.
+      !  
+      call p%precv(level+1)%map_prol(zone,&
+           & mlwrk(level+1)%y2l,zone,mlwrk(level)%y2l,&
+           & info,work=work)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during prolongation')
+        goto 9999
+      end if
+
+
+    end if
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine amg_z_inner_add
+
+  recursive subroutine amg_z_inner_mult(p, mlwrk, level, trans, work)
+    use psb_base_mod
+    use amg_prec_mod
+
+    implicit none
+
+    !Input/Oputput variables
+    type(amg_zprec_type), intent(inout)  :: p
+
+    type(amg_mlwrk_type), target,  intent(inout) :: mlwrk(:)
+    integer(psb_ipk_), intent(in) :: level
+    character, intent(in)             :: trans
+    complex(psb_dpk_),target            :: work(:)
+    type(psb_z_vect_type) :: res
+    type(psb_z_vect_type), pointer :: current
+    integer(psb_ipk_) :: sweeps_post, sweeps_pre
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: np, me
+    integer(psb_ipk_)   :: i, err_act
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    integer(psb_ipk_)   :: nlev, ilev, sweeps
+    logical             :: pre, post
+    character(len=20)   :: name
+
+
+
+    name = 'inner_inner_mult'
+    info = psb_success_
+    call psb_erractionsave(err_act)
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    nlev = size(p%precv)
+    if ((level < 1) .or. (level > nlev)) then
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong call level to inner_mult')
+      goto 9999      
+    end if
+    ctxt = p%precv(level)%base_desc%get_context()
+    call psb_info(ctxt, me, np)
+
+    if(debug_level > 1) then
+      write(debug_unit,*) me,' inner_mult at level ',level
+    end if
+
+    if ((level < nlev).or.(nlev == 1)) then
+      sweeps_post = p%precv(level)%parms%sweeps_post
+      sweeps_pre  = p%precv(level)%parms%sweeps_pre
+    else
+      sweeps_post = p%precv(level-1)%parms%sweeps_post
+      sweeps_pre  = p%precv(level-1)%parms%sweeps_pre
+    endif
+
+    pre  = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
+    post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N'))
+
+    
+    if (level < nlev) then 
+
+      !
+      ! Apply the first smoother
+      !
+
+      if (pre) then
+        if (trans == 'N') then 
+          sweeps = p%precv(level)%parms%sweeps_pre
+          if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
+               & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Y')
+        else
+          sweeps = p%precv(level)%parms%sweeps_post
+          if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
+               & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Y')
+        end if
+        
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during PRE smoother_apply')
+          goto 9999
+        end if
+      endif
+
+      !
+      ! Compute the residual and call recursively
+      !
+      if (pre) then
+        call psb_geaxpby(zone,mlwrk(level)%x2l,&
+             & zzero,mlwrk(level)%ty,&
+             & p%precv(level)%base_desc,info)
+        
+        if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,&
+             & mlwrk(level)%y2l,zone,mlwrk(level)%ty,&
+             & p%precv(level)%base_desc,info,work=work,trans=trans)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during residue')
+          goto 9999
+        end if
+        call p%precv(level+1)%map_rstr(zone,mlwrk(level)%ty,&
+             & zzero,mlwrk(level+1)%x2l,info,work=work)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during restriction')
+          goto 9999
+        end if
+      else
+        ! Shortcut: just transfer x2l. 
+        call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,&
+             & zzero,mlwrk(level+1)%x2l,info,work=work)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during restriction')
+          goto 9999
+        end if
+      endif
+      ! First guess is zero
+      mlwrk(level+1)%y2l(:) = zzero
+      
+      
+      call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      
+      if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
+        ! On second call will use output y2l as initial guess
+        if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info)
+      endif
+      
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in recursive call')
+        goto 9999
+      end if
+      
+      
+      !
+      ! Apply the prolongator
+      !  
+      call p%precv(level+1)%map_prol(zone,mlwrk(level+1)%y2l,&
+           & zone,mlwrk(level)%y2l,info,work=work)
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error during prolongation')
+        goto 9999
+      end if
+      
+      !
+      ! Compute the residual
+      !
+      if (post) then
+        call psb_geaxpby(zone,mlwrk(level)%x2l,&
+             & zzero,mlwrk(level)%tx,&
+             & p%precv(level)%base_desc,info)
+        call psb_spmm(-zone,p%precv(level)%base_a,mlwrk(level)%y2l,&
+             & zone,mlwrk(level)%tx,p%precv(level)%base_desc,info,&
+             & work=work,trans=trans)
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during residue')
+          goto 9999
+        end if
+        !
+        ! Apply the second smoother
+        !
+        if (trans == 'N') then
+          sweeps = p%precv(level)%parms%sweeps_post
+          if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
+               & mlwrk(level)%tx,zone,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Z')
+        else 
+          sweeps = p%precv(level)%parms%sweeps_pre
+          if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
+               & mlwrk(level)%tx,zone,mlwrk(level)%y2l,&
+               & p%precv(level)%base_desc, trans,&
+               & sweeps,work,info,init='Z')
+        end if
+        
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error during POST smoother_apply')
+          goto 9999
+        end if
+        
+      endif            
+      
+    else if (level == nlev) then
+      
+      sweeps = p%precv(level)%parms%sweeps_pre
+      if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
+           & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,&
+           & p%precv(level)%base_desc, trans,&
+           & sweeps,work,info)
+
+    else
+
+      info = psb_err_internal_error_ 
+      call psb_errpush(info,name,&
+           & a_err='Invalid LEVEL vs NLEV')
+      goto 9999
+    end if
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  end subroutine amg_z_inner_mult
+    
+
+end subroutine amg_zmlprec_aply_a

amgprec/impl/amg_zprecinit.F90

@@ -217,9 +217,7 @@ subroutine amg_zprecinit(ctxt,prec,ptype,info)
     allocate(amg_z_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
     call prec%precv(ilev_)%default()
 
-
   case ('ML')
-
     nlev_ = prec%ag_data%max_levs
     ilev_ = 1
     allocate(prec%precv(nlev_),stat=info)
@@ -231,6 +229,8 @@ subroutine amg_zprecinit(ctxt,prec,ptype,info)
     do ilev_ = 1, nlev_
       call prec%precv(ilev_)%default()
     end do
+    call prec%set_nlevs(nlev_) 
+
     call prec%set('ML_CYCLE','VCYCLE',info)
     call prec%set('SMOOTHER_TYPE','FBGS',info)
 #if defined(AMG_HAVE_UMF)
@@ -246,7 +246,6 @@ subroutine amg_zprecinit(ctxt,prec,ptype,info)
     write(psb_err_unit,*) name,&
          &': Warning: Unknown preconditioner type request "',ptype,'"'
     info = psb_err_pivot_too_small_
-
   end select
 
   call psb_erractionrestore(err_act)

amgprec/impl/level/Makefile

@@ -75,7 +75,12 @@ amg_z_base_onelev_setag.o \
 amg_z_base_onelev_setsm.o \
 amg_z_base_onelev_setsv.o \
 amg_z_base_onelev_map_rstr.o \
-amg_z_base_onelev_map_prol.o 
+amg_z_base_onelev_map_prol.o \
+amg_s_base_onelev_wrk_handle.o \
+amg_d_base_onelev_wrk_handle.o \
+amg_c_base_onelev_wrk_handle.o \
+amg_z_base_onelev_wrk_handle.o 
+
 
 
 LIBNAME=libamg_prec.a
@@ -89,4 +94,4 @@ veryclean: clean
 	/bin/rm -f $(LIBNAME)
 
 clean:
-	/bin/rm -f $(OBJS) $(LOCAL_MODS)
+	/bin/rm -f $(OBJS) $(LOCAL_MODS) *.smod

amgprec/impl/level/amg_c_base_onelev_build.f90

@@ -35,129 +35,132 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_build_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_build
-  implicit none
-  class(amg_c_onelev_type), target, intent(inout) :: lv
-  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
-  integer(psb_ipk_), intent(in), optional :: ilv
-  ! Local
-  integer(psb_ipk_)   :: err,i,k, err_act
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: me, np
-  integer(psb_ipk_)   :: debug_level, debug_unit
-  character(len=20)   :: name, ch_err
+  
+contains
+  module  subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+    implicit none
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    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
+    integer(psb_ipk_), intent(in), optional :: ilv
+    ! Local
+    integer(psb_ipk_)   :: err,i,k, err_act
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: me, np
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    character(len=20)   :: name, ch_err
 
-  name = 'amg_onelev_build'
-  info=psb_success_
-  err=0
-  call psb_erractionsave(err_act)
-  if (psb_errstatus_fatal()) then
-    info = psb_err_internal_error_; goto 9999
-  end if
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  if (.not.associated(lv%base_desc)) then
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,&
-         & a_err='Unassociated base DESC')
-    goto 9999
-  end if
-  info = psb_success_
-  ctxt = lv%base_desc%get_ctxt()
-  call psb_info(ctxt,me,np)
-
-  !
-  ! At top level(s) I may be using
-  ! a context with less processes
-  !
-  if (me < 0) then
-!!$    write(0,*) 'onelevbld: I am excluded from this one '
-  else
-!!$    write(0,*) me,' Going to build smoothers at this level '
-    if (.not.allocated(lv%sm)) then 
-      !! Error: should have called amg_dprecinit
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
+    name = 'amg_onelev_build'
+    info=psb_success_
+    err=0
+    call psb_erractionsave(err_act)
+    if (psb_errstatus_fatal()) then
+      info = psb_err_internal_error_; goto 9999
     end if
-    if (.not.allocated(lv%sm%sv)) then 
-      !! Error: should have called amg_dprecinit
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-    lv%ac_nz_loc = lv%ac%get_nzeros()
-    lv%ac_nz_tot = lv%ac_nz_loc
-    select case(lv%parms%coarse_mat)
-    case(amg_distr_mat_) 
-      call psb_sum(ctxt,lv%ac_nz_tot)
-    case(amg_repl_mat_)
-      ! Do nothing
-    case default
-      ! Should never get here
-      info = psb_err_internal_error_
-      call psb_errpush(info,name,a_err='Wrong lv%parms')
-      goto 9999
-    end select
-    
-    
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Calling mlprcbld at level  ',i
-    call amg_check_def(lv%parms%sweeps_pre,&
-         & 'Jacobi sweeps',izero,is_int_non_negative)
-    call amg_check_def(lv%parms%sweeps_post,&
-         & 'Jacobi sweeps',izero,is_int_non_negative)
-    
-    call lv%sm%build(lv%base_a,lv%base_desc,info)
-    if (info == 0) then
-      if (allocated(lv%sm2a)) then 
-        call lv%sm2a%build(lv%base_a,lv%base_desc,info)
-        lv%sm2 => lv%sm2a
-      else
-        lv%sm2 => lv%sm
-      end if
-    end if
-    if (info /=0 ) then
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    if (.not.associated(lv%base_desc)) then
       info = psb_err_internal_error_
       call psb_errpush(info,name,&
-           & a_err='Smoother bld error')
+           & a_err='Unassociated base DESC')
       goto 9999
     end if
-    
-    if (lv%sm%sv%is_global()) then
-      if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
-        lv%parms%sweeps_pre  = 1
-        lv%parms%sweeps_post = 1
-        if (me == 0) then
-          write(debug_unit,*) 
-          if (present(ilv)) then
-            write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
-                 & '" at level ',ilv
-            write(debug_unit,*) '         is configured as a global solver '
-          else
-            write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
-                 & '" is configured as a global solver '
+    info = psb_success_
+    ctxt = lv%base_desc%get_ctxt()
+    call psb_info(ctxt,me,np)
+
+    !
+    ! At top level(s) I may be using
+    ! a context with less processes
+    !
+    if (me < 0) then
+!!$    write(0,*) 'onelevbld: I am excluded from this one '
+    else
+!!$    write(0,*) me,' Going to build smoothers at this level '
+      if (.not.allocated(lv%sm)) then 
+        !! Error: should have called amg_dprecinit
+        info=3111
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+      if (.not.allocated(lv%sm%sv)) then 
+        !! Error: should have called amg_dprecinit
+        info=3111
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+      lv%ac_nz_loc = lv%ac%get_nzeros()
+      lv%ac_nz_tot = lv%ac_nz_loc
+      select case(lv%parms%coarse_mat)
+      case(amg_distr_mat_) 
+        call psb_sum(ctxt,lv%ac_nz_tot)
+      case(amg_repl_mat_)
+        ! Do nothing
+      case default
+        ! Should never get here
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,a_err='Wrong lv%parms')
+        goto 9999
+      end select
+
+
+      if (debug_level >= psb_debug_outer_) &
+           & write(debug_unit,*) me,' ',trim(name),&
+           & 'Calling mlprcbld at level  ',i
+      call amg_check_def(lv%parms%sweeps_pre,&
+           & 'Jacobi sweeps',izero,is_int_non_negative)
+      call amg_check_def(lv%parms%sweeps_post,&
+           & 'Jacobi sweeps',izero,is_int_non_negative)
+
+      call lv%sm%build(lv%base_a,lv%base_desc,info)
+      if (info == 0) then
+        if (allocated(lv%sm2a)) then 
+          call lv%sm2a%build(lv%base_a,lv%base_desc,info)
+          lv%sm2 => lv%sm2a
+        else
+          lv%sm2 => lv%sm
+        end if
+      end if
+      if (info /=0 ) then
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,&
+             & a_err='Smoother bld error')
+        goto 9999
+      end if
+
+      if (lv%sm%sv%is_global()) then
+        if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
+          lv%parms%sweeps_pre  = 1
+          lv%parms%sweeps_post = 1
+          if (me == 0) then
+            write(debug_unit,*) 
+            if (present(ilv)) then
+              write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
+                   & '" at level ',ilv
+              write(debug_unit,*) '         is configured as a global solver '
+            else
+              write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
+                   & '" is configured as a global solver '
+            end if
+            write(debug_unit,*) '        Pre and post sweeps at this level reset to 1'
           end if
-          write(debug_unit,*) '        Pre and post sweeps at this level reset to 1'
         end if
       end if
     end if
-  end if
-  
-  if (any((/present(amold),present(vmold),present(imold)/))) &
-       & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
 
-  call psb_erractionrestore(err_act)
-  return
+    if (any((/present(amold),present(vmold),present(imold)/))) &
+         & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
+
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
 
-  return
+    return
 
-end subroutine amg_c_base_onelev_build
+  end subroutine amg_c_base_onelev_build
+end submodule amg_c_base_onelev_build_impl

amgprec/impl/level/amg_c_base_onelev_check.f90

@@ -35,59 +35,60 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_check(lv,info)
-  
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_check_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_check
-
-  Implicit None
-
-  ! Arguments
-  class(amg_c_onelev_type), intent(inout) :: lv 
-  integer(psb_ipk_), intent(out)            :: info
-  integer(psb_ipk_)           :: err_act
-  character(len=20) :: name='c_base_onelev_check'
-
-  call psb_erractionsave(err_act)
-  info = psb_success_
-
-  call amg_check_def(lv%parms%sweeps_pre,&
-       & 'Jacobi sweeps',ione,is_int_non_negative)
-  call amg_check_def(lv%parms%sweeps_post,&
-       & 'Jacobi sweeps',ione,is_int_non_negative)
-
-  if (allocated(lv%sm)) then 
-    call lv%sm%check(info)
-  else 
-    info=3111
-    call psb_errpush(info,name)
-    goto 9999
-  end if
-
-  if (allocated(lv%sm2a)) then 
-    call lv%sm2a%check(info)
-  else if (.not.inner_check(lv%sm2,lv%sm)) then 
-    info=3111
-    call psb_errpush(info,name)
-    goto 9999
-  end if
-
-  if (info /= psb_success_) goto 9999
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-  return
 
 contains
-  function inner_check(smp,sm) result(res)
-    implicit none
-    logical :: res
-    class(amg_c_base_smoother_type), intent(in), pointer :: smp 
-    class(amg_c_base_smoother_type), intent(in), target  :: sm
+  module subroutine amg_c_base_onelev_check(lv,info)
+    Implicit None
 
-    res = associated(smp, sm)
-  end function inner_check
-  
-end subroutine amg_c_base_onelev_check
+    ! Arguments
+    class(amg_c_onelev_type), intent(inout) :: lv 
+    integer(psb_ipk_), intent(out)            :: info
+    integer(psb_ipk_)           :: err_act
+    character(len=20) :: name='c_base_onelev_check'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call amg_check_def(lv%parms%sweeps_pre,&
+         & 'Jacobi sweeps',ione,is_int_non_negative)
+    call amg_check_def(lv%parms%sweeps_post,&
+         & 'Jacobi sweeps',ione,is_int_non_negative)
+
+    if (allocated(lv%sm)) then 
+      call lv%sm%check(info)
+    else 
+      info=3111
+      call psb_errpush(info,name)
+      goto 9999
+    end if
+
+    if (allocated(lv%sm2a)) then 
+      call lv%sm2a%check(info)
+    else if (.not.inner_check(lv%sm2,lv%sm)) then 
+      info=3111
+      call psb_errpush(info,name)
+      goto 9999
+    end if
+
+    if (info /= psb_success_) goto 9999
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  contains
+    function inner_check(smp,sm) result(res)
+      implicit none
+      logical :: res
+      class(amg_c_base_smoother_type), intent(in), pointer :: smp 
+      class(amg_c_base_smoother_type), intent(in), target  :: sm
+
+      res = associated(smp, sm)
+    end function inner_check
+
+  end subroutine amg_c_base_onelev_check
+end submodule amg_c_base_onelev_check_impl

amgprec/impl/level/amg_c_base_onelev_cnv.f90

@@ -35,33 +35,36 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
-  
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_cnv_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_cnv
-  implicit none 
-
-  class(amg_c_onelev_type), intent(inout) :: lv
-  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
-
-  integer(psb_ipk_) :: i
-
-  info = psb_success_
   
-  if (any((/present(amold),present(vmold),present(imold)/))) then 
-    if (allocated(lv%sm)) &
-         & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
-    if (info == psb_success_ .and. allocated(lv%sm2a)) &
-         & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
-    if (info == psb_success_ .and. allocated(lv%wrk)) &
-         & call lv%wrk%cnv(info,vmold=vmold)
-    if (info == psb_success_.and. lv%ac%is_asb()) &
-         & call lv%ac%cscnv(info,mold=amold)
-    if (info == psb_success_ .and. lv%desc_ac%is_ok() &
-         & .and. present(imold)) call lv%desc_ac%cnv(imold)
-    if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
-  end if
-end subroutine amg_c_base_onelev_cnv
+contains
+  module subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
+
+    implicit none 
+
+    class(amg_c_onelev_type), intent(inout) :: lv
+    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
+
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+
+    if (any((/present(amold),present(vmold),present(imold)/))) then 
+      if (allocated(lv%sm)) &
+           & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
+      if (info == psb_success_ .and. allocated(lv%sm2a)) &
+           & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
+      if (info == psb_success_ .and. allocated(lv%wrk)) &
+           & call lv%wrk%cnv(info,vmold=vmold)
+      if (info == psb_success_.and. lv%ac%is_asb()) &
+           & call lv%ac%cscnv(info,mold=amold)
+      if (info == psb_success_ .and. lv%desc_ac%is_ok() &
+           & .and. present(imold)) call lv%desc_ac%cnv(imold)
+      if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
+    end if
+  end subroutine amg_c_base_onelev_cnv
+end submodule amg_c_base_onelev_cnv_impl

amgprec/impl/level/amg_c_base_onelev_csetc.F90

@@ -35,277 +35,281 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !
 !
-subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
-
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_csetc_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_csetc
-  use amg_c_base_aggregator_mod
-  use amg_c_dec_aggregator_mod
-  use amg_c_symdec_aggregator_mod
-  use amg_c_jac_smoother
-  use amg_c_as_smoother
-  use amg_c_diag_solver
-  use amg_c_l1_diag_solver
-  use amg_c_jac_solver
-  use amg_c_ilu_solver
-  use amg_c_id_solver
-  use amg_c_gs_solver
-  use amg_c_ainv_solver
-  use amg_c_invk_solver
-  use amg_c_invt_solver
+  
+contains
+  module subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
+
+    use psb_base_mod
+    use amg_c_base_aggregator_mod
+    use amg_c_dec_aggregator_mod
+    use amg_c_symdec_aggregator_mod
+    use amg_c_jac_smoother
+    use amg_c_as_smoother
+    use amg_c_diag_solver
+    use amg_c_l1_diag_solver
+    use amg_c_jac_solver
+    use amg_c_ilu_solver
+    use amg_c_id_solver
+    use amg_c_gs_solver
+    use amg_c_ainv_solver
+    use amg_c_invk_solver
+    use amg_c_invt_solver
 #if defined(AMG_HAVE_SLU)
-  use amg_c_slu_solver
+    use amg_c_slu_solver
 #endif
 #if defined(AMG_HAVE_MUMPS)
-  use amg_c_mumps_solver
+    use amg_c_mumps_solver
 #endif
 
-  Implicit None
+    Implicit None
 
-  ! Arguments
-  class(amg_c_onelev_type), intent(inout) :: lv
-  character(len=*), intent(in)              :: what
-  character(len=*), intent(in)              :: val
-  integer(psb_ipk_), intent(out)            :: info
-  character(len=*), optional, intent(in)    :: pos
-  integer(psb_ipk_), intent(in), optional   :: idx
-  ! Local
-  integer(psb_ipk_)  :: ipos_, err_act
-  character(len=20) :: name='c_base_onelev_csetc'
-  integer(psb_ipk_) :: ival
-  type(amg_c_base_smoother_type)   :: amg_c_base_smoother_mold
-  type(amg_c_jac_smoother_type)    ::  amg_c_jac_smoother_mold
-  type(amg_c_l1_jac_smoother_type) ::  amg_c_l1_jac_smoother_mold
-  type(amg_c_as_smoother_type)     ::  amg_c_as_smoother_mold
-  type(amg_c_diag_solver_type)     ::  amg_c_diag_solver_mold
-  type(amg_c_l1_diag_solver_type)  ::  amg_c_l1_diag_solver_mold
-  type(amg_c_jac_solver_type)      ::  amg_c_jac_solver_mold
-  type(amg_c_l1_jac_solver_type)   ::  amg_c_l1_jac_solver_mold
-  type(amg_c_ilu_solver_type)      ::  amg_c_ilu_solver_mold
-  type(amg_c_id_solver_type)       ::  amg_c_id_solver_mold
-  type(amg_c_gs_solver_type)       ::  amg_c_gs_solver_mold
-  type(amg_c_bwgs_solver_type)     ::  amg_c_bwgs_solver_mold
-  type(amg_c_ainv_solver_type)     ::  amg_c_ainv_solver_mold
-  type(amg_c_invk_solver_type)     ::  amg_c_invk_solver_mold
-  type(amg_c_invt_solver_type)     ::  amg_c_invt_solver_mold
+    ! Arguments
+    class(amg_c_onelev_type), intent(inout) :: lv
+    character(len=*), intent(in)              :: what
+    character(len=*), intent(in)              :: val
+    integer(psb_ipk_), intent(out)            :: info
+    character(len=*), optional, intent(in)    :: pos
+    integer(psb_ipk_), intent(in), optional   :: idx
+    ! Local
+    integer(psb_ipk_)  :: ipos_, err_act
+    character(len=20) :: name='c_base_onelev_csetc'
+    integer(psb_ipk_) :: ival
+    type(amg_c_base_smoother_type)   :: amg_c_base_smoother_mold
+    type(amg_c_jac_smoother_type)    ::  amg_c_jac_smoother_mold
+    type(amg_c_l1_jac_smoother_type) ::  amg_c_l1_jac_smoother_mold
+    type(amg_c_as_smoother_type)     ::  amg_c_as_smoother_mold
+    type(amg_c_diag_solver_type)     ::  amg_c_diag_solver_mold
+    type(amg_c_l1_diag_solver_type)  ::  amg_c_l1_diag_solver_mold
+    type(amg_c_jac_solver_type)      ::  amg_c_jac_solver_mold
+    type(amg_c_l1_jac_solver_type)   ::  amg_c_l1_jac_solver_mold
+    type(amg_c_ilu_solver_type)      ::  amg_c_ilu_solver_mold
+    type(amg_c_id_solver_type)       ::  amg_c_id_solver_mold
+    type(amg_c_gs_solver_type)       ::  amg_c_gs_solver_mold
+    type(amg_c_bwgs_solver_type)     ::  amg_c_bwgs_solver_mold
+    type(amg_c_ainv_solver_type)     ::  amg_c_ainv_solver_mold
+    type(amg_c_invk_solver_type)     ::  amg_c_invk_solver_mold
+    type(amg_c_invt_solver_type)     ::  amg_c_invt_solver_mold
 #if defined(AMG_HAVE_SLU)
-  type(amg_c_slu_solver_type)   ::  amg_c_slu_solver_mold
+    type(amg_c_slu_solver_type)   ::  amg_c_slu_solver_mold
 #endif
 #if defined(AMG_HAVE_MUMPS)
-  type(amg_c_mumps_solver_type) ::  amg_c_mumps_solver_mold
+    type(amg_c_mumps_solver_type) ::  amg_c_mumps_solver_mold
 #endif
 
 
-  call psb_erractionsave(err_act)
+    call psb_erractionsave(err_act)
 
-  info = psb_success_
+    info = psb_success_
 
-  ival = lv%stringval(val)
+    ival = lv%stringval(val)
 
 
-  if (present(pos)) then
-    select case(psb_toupper(trim(pos)))
-    case('PRE')
-      ipos_ = amg_smooth_pre_
-    case('POST')
-      ipos_ = amg_smooth_post_
-    case default
+    if (present(pos)) then
+      select case(psb_toupper(trim(pos)))
+      case('PRE')
+        ipos_ = amg_smooth_pre_
+      case('POST')
+        ipos_ = amg_smooth_post_
+      case default
+        ipos_ = amg_smooth_both_
+      end select
+    else
       ipos_ = amg_smooth_both_
-    end select
-  else
-    ipos_ = amg_smooth_both_
-  end if
-
-  select case (psb_toupper(trim(what)))
-  case ('SMOOTHER_TYPE')
-    select case (psb_toupper(trim(val)))
-    case ('NOPREC','NONE')
-      call lv%set(amg_c_base_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos)
-
-    case ('JAC','JACOBI')
-      call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos)
-
-    case ('L1-JACOBI')
-      call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
-
-    case ('BJAC')
-      call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
-
-    case ('L1-BJAC')
-      call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
-
-    case ('AS')
-      call lv%set(amg_c_as_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
-
-    case ('GS','FWGS')
-      call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
-      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
-    case ('BWGS')
-      call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre')
-      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
-    case ('FBGS')
-      call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
-      call lv%set(amg_c_jac_smoother_mold,info,pos='post')
-      if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
-    case ('L1-GS','L1-FWGS')
-      call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
-      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
-    case ('L1-BWGS')
-      call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre')
-      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
-    case ('L1-FBGS')
-      call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
-      call lv%set(amg_c_l1_jac_smoother_mold,info,pos='post')
-      if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
-
-    case default
-      !
-      ! Do nothing and hope for the best :)
-      !
-    end select
-    if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm)) call lv%sm%default()
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm2a)) call lv%sm2a%default()
     end if
 
+    select case (psb_toupper(trim(what)))
+    case ('SMOOTHER_TYPE')
+      select case (psb_toupper(trim(val)))
+      case ('NOPREC','NONE')
+        call lv%set(amg_c_base_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos)
 
-  case('SUB_SOLVE')
-    select case (psb_toupper(trim(val)))
-    case ('NONE','NOPREC','FACT_NONE')
-      call lv%set(amg_c_id_solver_mold,info,pos=pos)
+      case ('JAC','JACOBI')
+        call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos)
 
-    case ('DIAG','JACOBI')
-      call lv%set(amg_c_diag_solver_mold,info,pos=pos)
+      case ('L1-JACOBI')
+        call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
 
-    case ('L1-DIAG','L1-JACOBI')
-      call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
+      case ('BJAC')
+        call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
 
-    case ('GS','FGS','FWGS')
-      call lv%set(amg_c_gs_solver_mold,info,pos=pos)
+      case ('L1-BJAC')
+        call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
 
-    case ('BGS','BWGS')
-      call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
+      case ('AS')
+        call lv%set(amg_c_as_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
 
-    case ('AINV')
-      call lv%set(amg_c_ainv_solver_mold,info,pos=pos)
-    case ('INVK')
-      call lv%set(amg_c_invk_solver_mold,info,pos=pos)
-    case ('INVT')
-      call lv%set(amg_c_invt_solver_mold,info,pos=pos)
-    case ('ILU','ILUT','MILU')
-      call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
-      if (info == 0) then
-        if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
-          call lv%sm%sv%set('SUB_SOLVE',val,info)
-        end if
-        if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
-          if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
-        end if
+      case ('GS','FWGS')
+        call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
+        if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+      case ('BWGS')
+        call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre')
+        if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+      case ('FBGS')
+        call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
+        call lv%set(amg_c_jac_smoother_mold,info,pos='post')
+        if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
+      case ('L1-GS','L1-FWGS')
+        call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
+        if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+      case ('L1-BWGS')
+        call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre')
+        if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+      case ('L1-FBGS')
+        call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
+        call lv%set(amg_c_l1_jac_smoother_mold,info,pos='post')
+        if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
+
+      case default
+        !
+        ! Do nothing and hope for the best :)
+        !
+      end select
+      if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm)) call lv%sm%default()
       end if
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm2a)) call lv%sm2a%default()
+      end if
+
+
+    case('SUB_SOLVE')
+      select case (psb_toupper(trim(val)))
+      case ('NONE','NOPREC','FACT_NONE')
+        call lv%set(amg_c_id_solver_mold,info,pos=pos)
+
+      case ('DIAG','JACOBI')
+        call lv%set(amg_c_diag_solver_mold,info,pos=pos)
+
+      case ('L1-DIAG','L1-JACOBI')
+        call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
+
+      case ('GS','FGS','FWGS')
+        call lv%set(amg_c_gs_solver_mold,info,pos=pos)
+
+      case ('BGS','BWGS')
+        call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
+
+      case ('AINV')
+        call lv%set(amg_c_ainv_solver_mold,info,pos=pos)
+      case ('INVK')
+        call lv%set(amg_c_invk_solver_mold,info,pos=pos)
+      case ('INVT')
+        call lv%set(amg_c_invt_solver_mold,info,pos=pos)
+      case ('ILU','ILUT','MILU')
+        call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
+        if (info == 0) then
+          if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
+            call lv%sm%sv%set('SUB_SOLVE',val,info)
+          end if
+          if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
+            if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
+          end if
+        end if
 #ifdef AMG_HAVE_SLU
-    case ('SLU')
-      call lv%set(amg_c_slu_solver_mold,info,pos=pos)
+      case ('SLU')
+        call lv%set(amg_c_slu_solver_mold,info,pos=pos)
 #endif
 #ifdef AMG_HAVE_MUMPS 
-    case ('MUMPS')
-      call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
+      case ('MUMPS')
+        call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
 #endif
-    case default
-      !
-      ! Do nothing and hope for the best :)
-      !
-    end select
+      case default
+        !
+        ! Do nothing and hope for the best :)
+        !
+      end select
 
-  case ('ML_CYCLE')
-    lv%parms%ml_cycle      = amg_stringval(val)
+    case ('ML_CYCLE')
+      lv%parms%ml_cycle      = amg_stringval(val)
 
-  case ('PAR_AGGR_ALG')
-    ival = amg_stringval(val)
-    lv%parms%par_aggr_alg  = ival
-    if (allocated(lv%aggr)) then
-      call lv%aggr%free(info)
-      if (info == 0) deallocate(lv%aggr,stat=info)
-      if (info /= 0) then
-        info = psb_err_internal_error_
-        call psb_errpush(info,name,a_err='aggregator deallocation?')
+    case ('PAR_AGGR_ALG')
+      ival = amg_stringval(val)
+      lv%parms%par_aggr_alg  = ival
+      if (allocated(lv%aggr)) then
+        call lv%aggr%free(info)
+        if (info == 0) deallocate(lv%aggr,stat=info)
+        if (info /= 0) then
+          info = psb_err_internal_error_
+          call psb_errpush(info,name,a_err='aggregator deallocation?')
+          goto 9999
+          return
+        end if
+      end if
+
+      select case(val)
+      case('DEC','DECOUPLED')
+        allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
+      case('SYMDEC')
+        allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)
+      case default
+        info =  psb_err_internal_error_
+        call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
         goto 9999
-        return
-      end if
-    end if
+      end select
+      if (info == psb_success_) call lv%aggr%default()
+
+    case ('AGGR_ORD')
+      lv%parms%aggr_ord      = amg_stringval(val)
+
+    case ('AGGR_TYPE')
+      lv%parms%aggr_type     = amg_stringval(val)
+      if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
+
+    case ('AGGR_PROL')
+      lv%parms%aggr_prol     = amg_stringval(val)
+
+    case ('COARSE_MAT')
+      lv%parms%coarse_mat    = amg_stringval(val)
+
+    case ('AGGR_OMEGA_ALG')
+      lv%parms%aggr_omega_alg= amg_stringval(val)
+
+    case ('AGGR_EIG')
+      lv%parms%aggr_eig      = amg_stringval(val)
+
+    case ('AGGR_FILTER')
+      lv%parms%aggr_filter   = amg_stringval(val)
+
+    case ('COARSE_SOLVE')
+      lv%parms%coarse_solve    = amg_stringval(val)
+
+    case default
+      if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm)) then
+          call lv%sm%set(what,val,info,idx=idx)
+        end if
+      end if
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
+        if (allocated(lv%sm2a)) then
+          call lv%sm2a%set(what,val,info,idx=idx)
+        end if
+      end if
+      if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
 
-    select case(val)
-    case('DEC','DECOUPLED')
-      allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
-    case('SYMDEC')
-      allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)
-  case default
-      info =  psb_err_internal_error_
-      call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
-      goto 9999
     end select
-    if (info == psb_success_) call lv%aggr%default()
-
-  case ('AGGR_ORD')
-    lv%parms%aggr_ord      = amg_stringval(val)
-
-  case ('AGGR_TYPE')
-    lv%parms%aggr_type     = amg_stringval(val)
-    if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
-
-  case ('AGGR_PROL')
-    lv%parms%aggr_prol     = amg_stringval(val)
-
-  case ('COARSE_MAT')
-    lv%parms%coarse_mat    = amg_stringval(val)
-
-  case ('AGGR_OMEGA_ALG')
-    lv%parms%aggr_omega_alg= amg_stringval(val)
-
-  case ('AGGR_EIG')
-    lv%parms%aggr_eig      = amg_stringval(val)
-
-  case ('AGGR_FILTER')
-    lv%parms%aggr_filter   = amg_stringval(val)
-
-  case ('COARSE_SOLVE')
-    lv%parms%coarse_solve    = amg_stringval(val)
-
-  case default
-    if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm)) then
-        call lv%sm%set(what,val,info,idx=idx)
-      end if
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
-      if (allocated(lv%sm2a)) then
-        call lv%sm2a%set(what,val,info,idx=idx)
-      end if
-    end if
-    if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
-
-  end select
 
 
-  if (info /= psb_success_) goto 9999
+    if (info /= psb_success_) goto 9999
 
-  call psb_erractionrestore(err_act)
-  return
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_c_base_onelev_csetc
+  end subroutine amg_c_base_onelev_csetc
+end submodule amg_c_base_onelev_csetc_impl

amgprec/impl/level/amg_c_base_onelev_cseti.F90

@@ -35,234 +35,238 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !
 !
-subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
-
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_cseti_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_cseti
-  use amg_c_base_aggregator_mod
-  use amg_c_dec_aggregator_mod
-  use amg_c_symdec_aggregator_mod
-  use amg_c_jac_smoother
-  use amg_c_as_smoother
-  use amg_c_diag_solver
-  use amg_c_l1_diag_solver
-  use amg_c_ilu_solver
-  use amg_c_id_solver
-  use amg_c_gs_solver
+  
+contains
+  module subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
+
+    use psb_base_mod
+    use amg_c_base_aggregator_mod
+    use amg_c_dec_aggregator_mod
+    use amg_c_symdec_aggregator_mod
+    use amg_c_jac_smoother
+    use amg_c_as_smoother
+    use amg_c_diag_solver
+    use amg_c_l1_diag_solver
+    use amg_c_ilu_solver
+    use amg_c_id_solver
+    use amg_c_gs_solver
 #if defined(AMG_HAVE_SLU)
-  use amg_c_slu_solver
+    use amg_c_slu_solver
 #endif
 #if defined(AMG_HAVE_MUMPS)
-  use amg_c_mumps_solver
+    use amg_c_mumps_solver
 #endif
 
-  Implicit None
+    Implicit None
 
-  ! Arguments
-  class(amg_c_onelev_type), intent(inout) :: lv
-  character(len=*), intent(in)              :: what
-  integer(psb_ipk_), intent(in)             :: val
-  integer(psb_ipk_), intent(out)            :: info
-  character(len=*), optional, intent(in)    :: pos
-  integer(psb_ipk_), intent(in), optional   :: idx
-  ! Local
-  integer(psb_ipk_)  :: ipos_, err_act
-  character(len=20) :: name='c_base_onelev_cseti'
-  type(amg_c_base_smoother_type)   :: amg_c_base_smoother_mold
-  type(amg_c_jac_smoother_type)    ::  amg_c_jac_smoother_mold
-  type(amg_c_l1_jac_smoother_type) ::  amg_c_l1_jac_smoother_mold
-  type(amg_c_as_smoother_type)     ::  amg_c_as_smoother_mold
-  type(amg_c_diag_solver_type)     ::  amg_c_diag_solver_mold
-  type(amg_c_l1_diag_solver_type)  ::  amg_c_l1_diag_solver_mold
-  type(amg_c_ilu_solver_type)      ::  amg_c_ilu_solver_mold
-  type(amg_c_id_solver_type)       ::  amg_c_id_solver_mold
-  type(amg_c_gs_solver_type)       ::  amg_c_gs_solver_mold
-  type(amg_c_bwgs_solver_type)     ::  amg_c_bwgs_solver_mold
+    ! Arguments
+    class(amg_c_onelev_type), intent(inout) :: lv
+    character(len=*), intent(in)              :: what
+    integer(psb_ipk_), intent(in)             :: val
+    integer(psb_ipk_), intent(out)            :: info
+    character(len=*), optional, intent(in)    :: pos
+    integer(psb_ipk_), intent(in), optional   :: idx
+    ! Local
+    integer(psb_ipk_)  :: ipos_, err_act
+    character(len=20) :: name='c_base_onelev_cseti'
+    type(amg_c_base_smoother_type)   :: amg_c_base_smoother_mold
+    type(amg_c_jac_smoother_type)    ::  amg_c_jac_smoother_mold
+    type(amg_c_l1_jac_smoother_type) ::  amg_c_l1_jac_smoother_mold
+    type(amg_c_as_smoother_type)     ::  amg_c_as_smoother_mold
+    type(amg_c_diag_solver_type)     ::  amg_c_diag_solver_mold
+    type(amg_c_l1_diag_solver_type)  ::  amg_c_l1_diag_solver_mold
+    type(amg_c_ilu_solver_type)      ::  amg_c_ilu_solver_mold
+    type(amg_c_id_solver_type)       ::  amg_c_id_solver_mold
+    type(amg_c_gs_solver_type)       ::  amg_c_gs_solver_mold
+    type(amg_c_bwgs_solver_type)     ::  amg_c_bwgs_solver_mold
 #if defined(AMG_HAVE_SLU)
-  type(amg_c_slu_solver_type)   ::  amg_c_slu_solver_mold
+    type(amg_c_slu_solver_type)   ::  amg_c_slu_solver_mold
 #endif
 #if defined(AMG_HAVE_MUMPS)
-  type(amg_c_mumps_solver_type) ::  amg_c_mumps_solver_mold
+    type(amg_c_mumps_solver_type) ::  amg_c_mumps_solver_mold
 #endif
 
-  call psb_erractionsave(err_act)
-  info = psb_success_
+    call psb_erractionsave(err_act)
+    info = psb_success_
 
-  if (present(pos)) then
-    select case(psb_toupper(trim(pos)))
-    case('PRE')
-      ipos_ = amg_smooth_pre_
-    case('POST')
-      ipos_ = amg_smooth_post_
-    case default
+    if (present(pos)) then
+      select case(psb_toupper(trim(pos)))
+      case('PRE')
+        ipos_ = amg_smooth_pre_
+      case('POST')
+        ipos_ = amg_smooth_post_
+      case default
+        ipos_ = amg_smooth_both_
+      end select
+    else
       ipos_ = amg_smooth_both_
-    end select
-  else
-    ipos_ = amg_smooth_both_
-  end if
-
-  select case (psb_toupper(what))
-  case ('SMOOTHER_TYPE')
-    select case (val)
-    case (amg_noprec_)
-      call lv%set(amg_c_base_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos)
-
-    case (amg_jac_)
-      call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos)
-
-    case (amg_l1_jac_)
-      call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
-
-    case (amg_bjac_)
-      call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
-
-    case (amg_l1_bjac_)
-      call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
-
-    case (amg_as_)
-      call lv%set(amg_c_as_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
-
-    case (amg_fbgs_)
-      call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
-      call lv%set(amg_c_jac_smoother_mold,info,pos='post')
-      if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
-
-    case default
-      !
-      ! Do nothing and hope for the best :)
-      !
-    end select
-    if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm)) call lv%sm%default()
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm2a)) call lv%sm2a%default()
     end if
 
+    select case (psb_toupper(what))
+    case ('SMOOTHER_TYPE')
+      select case (val)
+      case (amg_noprec_)
+        call lv%set(amg_c_base_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos)
 
-  case('SUB_SOLVE')
-    select case (val)
-    case (amg_f_none_)
-      call lv%set(amg_c_id_solver_mold,info,pos=pos)
+      case (amg_jac_)
+        call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos)
 
-    case (amg_diag_scale_)
-      call lv%set(amg_c_diag_solver_mold,info,pos=pos)
+      case (amg_l1_jac_)
+        call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
 
-    case (amg_l1_diag_scale_)
-      call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
+      case (amg_bjac_)
+        call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
 
-    case (amg_gs_)
-      call lv%set(amg_c_gs_solver_mold,info,pos=pos)
+      case (amg_l1_bjac_)
+        call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
 
-    case (amg_bwgs_)
-      call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
+      case (amg_as_)
+        call lv%set(amg_c_as_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
 
-    case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
-      call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
-      if (info == 0) then
-        if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
-          call lv%sm%sv%set('SUB_SOLVE',val,info)
-        end if
-        if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
-          if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
-        end if
+      case (amg_fbgs_)
+        call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
+        call lv%set(amg_c_jac_smoother_mold,info,pos='post')
+        if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
+
+      case default
+        !
+        ! Do nothing and hope for the best :)
+        !
+      end select
+      if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm)) call lv%sm%default()
       end if
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm2a)) call lv%sm2a%default()
+      end if
+
+
+    case('SUB_SOLVE')
+      select case (val)
+      case (amg_f_none_)
+        call lv%set(amg_c_id_solver_mold,info,pos=pos)
+
+      case (amg_diag_scale_)
+        call lv%set(amg_c_diag_solver_mold,info,pos=pos)
+
+      case (amg_l1_diag_scale_)
+        call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
+
+      case (amg_gs_)
+        call lv%set(amg_c_gs_solver_mold,info,pos=pos)
+
+      case (amg_bwgs_)
+        call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
+
+      case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
+        call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
+        if (info == 0) then
+          if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
+            call lv%sm%sv%set('SUB_SOLVE',val,info)
+          end if
+          if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
+            if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
+          end if
+        end if
 #ifdef AMG_HAVE_SLU
-    case (amg_slu_)
-      call lv%set(amg_c_slu_solver_mold,info,pos=pos)
+      case (amg_slu_)
+        call lv%set(amg_c_slu_solver_mold,info,pos=pos)
 #endif
 #ifdef AMG_HAVE_MUMPS
-    case (amg_mumps_)
-      call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
+      case (amg_mumps_)
+        call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
 #endif
+      case default
+        !
+        ! Do nothing and hope for the best :)
+        !
+      end select
+
+
+    case ('SMOOTHER_SWEEPS')
+      if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
+           &  lv%parms%sweeps_pre  = val
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
+           &  lv%parms%sweeps_post = val
+
+    case ('ML_CYCLE')
+      lv%parms%ml_cycle      = val
+
+    case ('PAR_AGGR_ALG')
+      lv%parms%par_aggr_alg  = val
+      if (allocated(lv%aggr)) then
+        call lv%aggr%free(info)
+        if (info == 0) deallocate(lv%aggr,stat=info)
+        if (info /= 0) then
+          info = psb_err_internal_error_
+          return
+        end if
+      end if
+
+      select case(val)
+      case(amg_dec_aggr_)
+        allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
+      case(amg_sym_dec_aggr_)
+        allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)
+      case default
+        info =  psb_err_internal_error_
+      end select
+      if (info == psb_success_) call lv%aggr%default()
+
+    case ('AGGR_ORD')
+      lv%parms%aggr_ord      = val
+
+    case ('AGGR_TYPE')
+      lv%parms%aggr_type     = val
+      if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
+
+    case ('AGGR_PROL')
+      lv%parms%aggr_prol     = val
+
+    case ('COARSE_MAT')
+      lv%parms%coarse_mat    = val
+
+    case ('AGGR_OMEGA_ALG')
+      lv%parms%aggr_omega_alg= val
+
+    case ('AGGR_EIG')
+      lv%parms%aggr_eig      = val
+
+    case ('AGGR_FILTER')
+      lv%parms%aggr_filter   = val
+
+    case ('COARSE_SOLVE')
+      lv%parms%coarse_solve    = val
+
     case default
-      !
-      ! Do nothing and hope for the best :)
-      !
+      if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm)) then
+          call lv%sm%set(what,val,info,idx=idx)
+        end if
+      end if
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
+        if (allocated(lv%sm2a)) then
+          call lv%sm2a%set(what,val,info,idx=idx)
+        end if
+      end if
+      if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
+
     end select
-
-
-  case ('SMOOTHER_SWEEPS')
-    if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
-         &  lv%parms%sweeps_pre  = val
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
-         &  lv%parms%sweeps_post = val
-
-  case ('ML_CYCLE')
-    lv%parms%ml_cycle      = val
-
-  case ('PAR_AGGR_ALG')
-    lv%parms%par_aggr_alg  = val
-    if (allocated(lv%aggr)) then
-      call lv%aggr%free(info)
-      if (info == 0) deallocate(lv%aggr,stat=info)
-      if (info /= 0) then
-        info = psb_err_internal_error_
-        return
-      end if
-    end if
-
-    select case(val)
-    case(amg_dec_aggr_)
-      allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
-    case(amg_sym_dec_aggr_)
-      allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)
-    case default
-      info =  psb_err_internal_error_
-    end select
-    if (info == psb_success_) call lv%aggr%default()
-
-  case ('AGGR_ORD')
-    lv%parms%aggr_ord      = val
-
-  case ('AGGR_TYPE')
-    lv%parms%aggr_type     = val
-    if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
-
-  case ('AGGR_PROL')
-    lv%parms%aggr_prol     = val
-
-  case ('COARSE_MAT')
-    lv%parms%coarse_mat    = val
-
-  case ('AGGR_OMEGA_ALG')
-    lv%parms%aggr_omega_alg= val
-
-  case ('AGGR_EIG')
-    lv%parms%aggr_eig      = val
-
-  case ('AGGR_FILTER')
-    lv%parms%aggr_filter   = val
-
-  case ('COARSE_SOLVE')
-    lv%parms%coarse_solve    = val
-
-  case default
-    if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm)) then
-        call lv%sm%set(what,val,info,idx=idx)
-      end if
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
-      if (allocated(lv%sm2a)) then
-        call lv%sm2a%set(what,val,info,idx=idx)
-      end if
-    end if
-    if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
-
-  end select
-  if (info /= psb_success_) goto 9999
-  call psb_erractionrestore(err_act)
-  return
+    if (info /= psb_success_) goto 9999
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_c_base_onelev_cseti
+  end subroutine amg_c_base_onelev_cseti
+end submodule amg_c_base_onelev_cseti_impl

amgprec/impl/level/amg_c_base_onelev_csetr.f90

@@ -35,71 +35,73 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
-  
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_csetr_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_csetr
+  
+contains
+  module subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
 
-  Implicit None
+    Implicit None
 
-  ! Arguments
-  class(amg_c_onelev_type), intent(inout) :: lv 
-  character(len=*), intent(in)              :: what 
-  real(psb_spk_), intent(in)                 :: val
-  integer(psb_ipk_), intent(out)            :: info
-  character(len=*), optional, intent(in)    :: pos
-  integer(psb_ipk_), intent(in), optional   :: idx
-  ! Local 
-  integer(psb_ipk_)  :: ipos_, err_act
-  character(len=20) :: name='c_base_onelev_csetr'
+    ! Arguments
+    class(amg_c_onelev_type), intent(inout) :: lv 
+    character(len=*), intent(in)              :: what 
+    real(psb_spk_), intent(in)                 :: val
+    integer(psb_ipk_), intent(out)            :: info
+    character(len=*), optional, intent(in)    :: pos
+    integer(psb_ipk_), intent(in), optional   :: idx
+    ! Local 
+    integer(psb_ipk_)  :: ipos_, err_act
+    character(len=20) :: name='c_base_onelev_csetr'
 
-  call psb_erractionsave(err_act)
+    call psb_erractionsave(err_act)
 
 
-  info = psb_success_
+    info = psb_success_
 
-  select case (psb_toupper(what))
+    select case (psb_toupper(what))
 
-  case ('AGGR_OMEGA_VAL')
-    lv%parms%aggr_omega_val= val
+    case ('AGGR_OMEGA_VAL')
+      lv%parms%aggr_omega_val= val
 
-  case ('AGGR_THRESH')
-    lv%parms%aggr_thresh   = val
+    case ('AGGR_THRESH')
+      lv%parms%aggr_thresh   = val
 
-  case default
-    
-    if (present(pos)) then
-      select case(psb_toupper(trim(pos)))
-      case('PRE')
-        ipos_ = amg_smooth_pre_
-      case('POST')
-        ipos_ = amg_smooth_post_
-      case default
+    case default
+
+      if (present(pos)) then
+        select case(psb_toupper(trim(pos)))
+        case('PRE')
+          ipos_ = amg_smooth_pre_
+        case('POST')
+          ipos_ = amg_smooth_post_
+        case default
+          ipos_ = amg_smooth_both_
+        end select
+      else
         ipos_ = amg_smooth_both_
-      end select
-    else
-      ipos_ = amg_smooth_both_
-    end if
-
-    if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then 
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info,idx=idx)
       end if
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then 
-      if (allocated(lv%sm2a)) then 
-        call lv%sm2a%set(what,val,info,idx=idx)
+
+      if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then 
+        if (allocated(lv%sm)) then 
+          call lv%sm%set(what,val,info,idx=idx)
+        end if
       end if
-    end if
-    if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then 
+        if (allocated(lv%sm2a)) then 
+          call lv%sm2a%set(what,val,info,idx=idx)
+        end if
+      end if
+      if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
 
-  end select
+    end select
 
-  if (info /= psb_success_) goto 9999
-  call psb_erractionrestore(err_act)
-  return
+    if (info /= psb_success_) goto 9999
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_c_base_onelev_csetr
+  end subroutine amg_c_base_onelev_csetr
+end submodule amg_c_base_onelev_csetr_impl

amgprec/impl/level/amg_c_base_onelev_descr.f90

@@ -42,108 +42,116 @@
 !         0: normal
 !        >1: increased details 
 !
-subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
-  
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_descr_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_descr
-  Implicit None
-  ! Arguments
-  class(amg_c_onelev_type), intent(in)    :: lv
-  integer(psb_ipk_), intent(in)           :: il,nl,ilmin
-  integer(psb_ipk_), intent(out)          :: info
-  integer(psb_ipk_), intent(in), optional :: iout
-  integer(psb_ipk_), intent(in), optional :: verbosity
-  character(len=*), intent(in), optional  :: prefix
-
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  character(len=20), parameter :: name='amg_c_base_onelev_descr'
-  integer(psb_ipk_)  :: iout_, verbosity_
-  logical      :: coarse
-  character(1024)    :: prefix_
-
-
-  call psb_erractionsave(err_act)
-
-
-  coarse = (il==nl)
-
-  if (present(iout)) then 
-    iout_ = iout
-  else 
-    iout_ = psb_out_unit
-  end if
   
-  if (present(verbosity)) then
-    verbosity_ = verbosity
-  else
-    verbosity_ = 0
-  end if
-  if (verbosity_ < 0) goto 9998
+contains
+  module subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
+    Implicit None
+    ! Arguments
+    class(amg_c_onelev_type), intent(in)    :: lv
+    integer(psb_ipk_), intent(in)           :: il,nl,ilmin
+    integer(psb_ipk_), intent(out)          :: info
+    integer(psb_ipk_), intent(in), optional :: iout
+    integer(psb_ipk_), intent(in), optional :: verbosity
+    character(len=*), intent(in), optional  :: prefix
+
+
+    ! Local variables
+    integer(psb_ipk_)  :: err_act
+    character(len=20), parameter :: name='amg_c_base_onelev_descr'
+    integer(psb_ipk_)  :: iout_, verbosity_
+    logical      :: coarse
+    character(1024)    :: prefix_
+    type(psb_ctxt_type) :: pctxt
+    integer(psb_ipk_)   :: pme, pnp
+
+
+    call psb_erractionsave(err_act)
+
+
+    coarse = (il==nl)
+
+    if (present(iout)) then 
+      iout_ = iout
+    else 
+      iout_ = psb_out_unit
+    end if
+
+    if (present(verbosity)) then
+      verbosity_ = verbosity
+    else
+      verbosity_ = 0
+    end if
+    if (verbosity_ < 0) goto 9998
     if (present(prefix)) then
       prefix_ = prefix
     else
       prefix_ = ""
     end if
 
-  write(iout_,*) trim(prefix_)
-  if (il == ilmin) then 
-    call lv%parms%mlcycledsc(iout_,info)
-  end if
-  if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then 
-    if (allocated(lv%aggr)) then
-      call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
-    else
-      write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
-      info = psb_err_internal_error_
-      call psb_errpush(info,name)
-      goto 9999
-    end if
+    pctxt = lv%desc_ac%get_ctxt()
+    call psb_info(pctxt,pme,pnp) 
     write(iout_,*) trim(prefix_)
-  end if
-  
-  if (il > 1) then 
-
-    if (coarse)  then 
-      write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
-    else
-      write(iout_,*) trim(prefix_), ' Level ',il
+    write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
+    write(iout_,*) trim(prefix_)
+    if (il == ilmin) then 
+      call lv%parms%mlcycledsc(iout_,info)
     end if
-
-    call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
-
-    if (nl > 1) then 
-      if (allocated(lv%linmap%naggr)) then
-        write(iout_,*) trim(prefix_), '  Coarse Matrix: Global size: ', &
-             &  lv%linmap%nagtot
-        write(iout_,*) trim(prefix_), '                    Nonzeros: ',lv%ac_nz_tot
-        if (verbosity_>0) then
-          write(iout_,*) trim(prefix_), '          Local matrix sizes: ', &
-               &  lv%linmap%naggr(:)
-        else 
-          write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
-               & '     Local  matrix sizes: min:', &
-               & lv%linmap%nagmin,'         max:', lv%linmap%nagmax
-          write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
-               & '                          avg:', &
-               & lv%linmap%nagavg
-        end if
-        write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
-             & '          Aggregation   ratio: ', &
-             &  lv%szratio
+    if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then 
+      if (allocated(lv%aggr)) then
+        call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
+      else
+        write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
+        info = psb_err_internal_error_
+        call psb_errpush(info,name)
+        goto 9999
       end if
+      write(iout_,*) trim(prefix_)
     end if
 
-    if (coarse.and.allocated(lv%sm)) &
-         & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
-  end if
+    if (il > 1) then 
+
+      if (coarse)  then 
+        write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
+      else
+        write(iout_,*) trim(prefix_), ' Level ',il
+      end if
+
+      call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
+
+      if (nl > 1) then 
+        if (allocated(lv%linmap%naggr)) then
+          write(iout_,*) trim(prefix_), '  Coarse Matrix: Global size: ', &
+               &  lv%linmap%nagtot
+          write(iout_,*) trim(prefix_), '                    Nonzeros: ',lv%ac_nz_tot
+          if (verbosity_>0) then
+            write(iout_,*) trim(prefix_), '          Local matrix sizes: ', &
+                 &  lv%linmap%naggr(:)
+          else 
+            write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
+                 & '     Local  matrix sizes: min:', &
+                 & lv%linmap%nagmin,'         max:', lv%linmap%nagmax
+            write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
+                 & '                          avg:', &
+                 & lv%linmap%nagavg
+          end if
+          write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
+               & '          Aggregation   ratio: ', &
+               &  lv%szratio
+        end if
+      end if
+
+      if (coarse.and.allocated(lv%sm)) &
+           & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
+    end if
 
 9998 continue
-  call psb_erractionrestore(err_act)
-  return
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_c_base_onelev_descr
+  end subroutine amg_c_base_onelev_descr
+end submodule amg_c_base_onelev_descr_impl

amgprec/impl/level/amg_c_base_onelev_dump.f90

@@ -35,135 +35,137 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
-     & smoother,solver,tprol,global_num)
-
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_dump_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_dump
-  implicit none 
-  class(amg_c_onelev_type), intent(in) :: lv
-  integer(psb_ipk_), intent(in)          :: level
-  integer(psb_ipk_), intent(out)         :: info
-  character(len=*), intent(in), optional :: prefix, head
-  logical, optional, intent(in)    :: ac, rp, smoother, solver, tprol, global_num
-  ! Local variables
-  integer(psb_ipk_)   :: i, j, il1, iln, lname, lev, ni
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: iam, np
-  character(len=80)   :: prefix_, frmt
-  character(len=1024) :: fname 
-  logical :: ac_, rp_, tprol_, global_num_
-  integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
-
-  info = 0
-
-  if (present(prefix)) then 
-    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-  else
-    prefix_ = "dump_lev_c"
-  end if
-
-  if (associated(lv%base_desc)) then 
-    ctxt = lv%base_desc%get_context()
-    call psb_info(ctxt,iam,np)
-  else 
-    iam     = -1
-    np      = -1
-  end if
-  if (present(ac)) then 
-    ac_ = ac
-  else
-    ac_ = .false. 
-  end if
-  if (present(rp)) then 
-    rp_ = rp
-  else
-    rp_ = .false. 
-  end if
-  if (present(tprol)) then 
-    tprol_ = tprol
-  else
-    tprol_ = .false. 
-  end if
-  if (present(global_num)) then 
-    global_num_ = global_num
-  else
-    global_num_ = .false. 
-  end if
-  lname = len_trim(prefix_)
-  fname = trim(prefix_)
-
-  if (np > 0) then 
-    ni  = floor(log10(1.0*np)) + 1
-    write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
-    write(fname(lname+1:lname+ni+2),frmt) '_p',iam
-    lname = lname + ni + 2
-  end if
-
-  if (global_num_) then
-    if (level == 1) then
-      if (ac_) then
-        ivr = lv%base_desc%get_global_indices(owned=.false.)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        call lv%base_a%print(fname,head=head,iv=ivr)
-      end if
-    else if (level >= 2) then 
-      if (ac_) then
-        ivr = lv%desc_ac%get_global_indices(owned=.false.)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        call lv%ac%print(fname,head=head,iv=ivr)
-      end if
-      if (rp_) then 
-        ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
-        ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
-        call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
-        call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
-      end if
-      if (tprol_) then
-        ! Tentative prolongator is stored with column indices already
-        ! in global numbering, so only IVR is needed. 
-        ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
-        !
-        call lv%tprol%print(fname,head=head,ivr=ivr)
-      end if
-    end if
-  else
-    if (level == 1) then
-      if (ac_) then
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        call lv%base_a%print(fname,head=head)
-      end if
-    else  if (level >= 2) then 
-      if (ac_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        call lv%ac%print(fname,head=head)
-      end if
-      if (rp_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
-        call lv%linmap%mat_U2V%print(fname,head=head)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
-        call lv%linmap%mat_V2U%print(fname,head=head)
-      end if
-      if (tprol_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
-        !
-        call lv%tprol%print(fname,head=head)
-      end if
-    end if
-  end if
   
-  if (level >= 1) then 
-    if (allocated(lv%sm)) then
-      call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
-           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+contains
+  module subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
+       & smoother,solver,tprol,global_num)
+    implicit none 
+    class(amg_c_onelev_type), intent(in) :: lv
+    integer(psb_ipk_), intent(in)          :: level
+    integer(psb_ipk_), intent(out)         :: info
+    character(len=*), intent(in), optional :: prefix, head
+    logical, optional, intent(in)    :: ac, rp, smoother, solver, tprol, global_num
+    ! Local variables
+    integer(psb_ipk_)   :: i, j, il1, iln, lname, lev, ni
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: iam, np
+    character(len=80)   :: prefix_, frmt
+    character(len=1024) :: fname 
+    logical :: ac_, rp_, tprol_, global_num_
+    integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
+
+    info = 0
+
+    if (present(prefix)) then 
+      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+    else
+      prefix_ = "dump_lev_c"
     end if
-    if (allocated(lv%sm2a)) then
-      call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
-           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+
+    if (associated(lv%base_desc)) then 
+      ctxt = lv%base_desc%get_context()
+      call psb_info(ctxt,iam,np)
+    else 
+      iam     = -1
+      np      = -1
     end if
-  end if
-  
-end subroutine amg_c_base_onelev_dump
+    if (present(ac)) then 
+      ac_ = ac
+    else
+      ac_ = .false. 
+    end if
+    if (present(rp)) then 
+      rp_ = rp
+    else
+      rp_ = .false. 
+    end if
+    if (present(tprol)) then 
+      tprol_ = tprol
+    else
+      tprol_ = .false. 
+    end if
+    if (present(global_num)) then 
+      global_num_ = global_num
+    else
+      global_num_ = .false. 
+    end if
+    lname = len_trim(prefix_)
+    fname = trim(prefix_)
+
+    if (np > 0) then 
+      ni  = floor(log10(1.0*np)) + 1
+      write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
+      write(fname(lname+1:lname+ni+2),frmt) '_p',iam
+      lname = lname + ni + 2
+    end if
+
+    if (global_num_) then
+      if (level == 1) then
+        if (ac_) then
+          ivr = lv%base_desc%get_global_indices(owned=.false.)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+          call lv%base_a%print(fname,head=head,iv=ivr)
+        end if
+      else if (level >= 2) then 
+        if (ac_) then
+          ivr = lv%desc_ac%get_global_indices(owned=.false.)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+          call lv%ac%print(fname,head=head,iv=ivr)
+        end if
+        if (rp_) then 
+          ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
+          ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
+          call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
+          call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
+        end if
+        if (tprol_) then
+          ! Tentative prolongator is stored with column indices already
+          ! in global numbering, so only IVR is needed. 
+          ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
+          !
+          call lv%tprol%print(fname,head=head,ivr=ivr)
+        end if
+      end if
+    else
+      if (level == 1) then
+        if (ac_) then
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+          call lv%base_a%print(fname,head=head)
+        end if
+      else  if (level >= 2) then 
+        if (ac_) then 
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+          call lv%ac%print(fname,head=head)
+        end if
+        if (rp_) then 
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
+          call lv%linmap%mat_U2V%print(fname,head=head)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
+          call lv%linmap%mat_V2U%print(fname,head=head)
+        end if
+        if (tprol_) then 
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
+          !
+          call lv%tprol%print(fname,head=head)
+        end if
+      end if
+    end if
+
+    if (level >= 1) then 
+      if (allocated(lv%sm)) then
+        call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
+             & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+      end if
+      if (allocated(lv%sm2a)) then
+        call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
+             & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+      end if
+    end if
+
+  end subroutine amg_c_base_onelev_dump
+end submodule amg_c_base_onelev_dump_impl

amgprec/impl/level/amg_c_base_onelev_free.f90

@@ -35,41 +35,43 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_free(lv,info)
-  
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_free_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_free
-  implicit none 
+  
+contains
+  module subroutine amg_c_base_onelev_free(lv,info)
+    implicit none 
 
-  class(amg_c_onelev_type), intent(inout) :: lv
-  integer(psb_ipk_), intent(out)          :: info
-  integer(psb_ipk_) :: i
+    class(amg_c_onelev_type), intent(inout) :: lv
+    integer(psb_ipk_), intent(out)          :: info
+    integer(psb_ipk_) :: i
 
-  info = psb_success_
+    info = psb_success_
 
-  ! We might just deallocate the top level array, except 
-  ! that there may be inner objects containing C pointers,
-  ! e.g.  UMFPACK, SLU or CUDA stuff.
-  ! We really need FINALs. 
-  if (allocated(lv%sm)) &
-       & call lv%sm%free(info)
+    ! We might just deallocate the top level array, except 
+    ! that there may be inner objects containing C pointers,
+    ! e.g.  UMFPACK, SLU or CUDA stuff.
+    ! We really need FINALs. 
+    if (allocated(lv%sm)) &
+         & call lv%sm%free(info)
 
-  if (allocated(lv%sm2a)) &
-       & call lv%sm2a%free(info)
+    if (allocated(lv%sm2a)) &
+         & call lv%sm2a%free(info)
 
-  if (allocated(lv%wrk)) &
-       & call lv%wrk%free(info)
+    if (allocated(lv%wrk)) &
+         & call lv%wrk%free(info)
 
-  call lv%ac%free()
-  if (lv%desc_ac%is_ok()) &
-       & call lv%desc_ac%free(info)
-  call lv%linmap%free(info)
+    call lv%ac%free()
+    if (lv%desc_ac%is_ok()) &
+         & call lv%desc_ac%free(info)
+    call lv%linmap%free(info)
 
-  ! This is a pointer to something else, must not free it here. 
-  nullify(lv%base_a) 
-  ! This is a pointer to something else, must not free it here. 
-  nullify(lv%base_desc) 
+    ! This is a pointer to something else, must not free it here. 
+    nullify(lv%base_a) 
+    ! This is a pointer to something else, must not free it here. 
+    nullify(lv%base_desc) 
 
-  call lv%nullify()
+    call lv%nullify()
 
-end subroutine amg_c_base_onelev_free
+  end subroutine amg_c_base_onelev_free
+end submodule amg_c_base_onelev_free_impl

amgprec/impl/level/amg_c_base_onelev_free_smoothers.f90

@@ -35,26 +35,28 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_free_smoothers(lv,info)
-  
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_dree_smoothers_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_free_smoothers
-  implicit none 
+  
+contains
+  module subroutine amg_c_base_onelev_free_smoothers(lv,info)
+    implicit none 
 
-  class(amg_c_onelev_type), intent(inout) :: lv
-  integer(psb_ipk_), intent(out)          :: info
-  integer(psb_ipk_) :: i
+    class(amg_c_onelev_type), intent(inout) :: lv
+    integer(psb_ipk_), intent(out)          :: info
+    integer(psb_ipk_) :: i
 
-  info = psb_success_
+    info = psb_success_
 
-  ! We might just deallocate the top level array, except 
-  ! that there may be inner objects containing C pointers,
-  ! e.g.  UMFPACK, SLU or CUDA stuff.
-  ! We really need FINALs. 
-  if (allocated(lv%sm)) &
-       & call lv%sm%free(info)
+    ! We might just deallocate the top level array, except 
+    ! that there may be inner objects containing C pointers,
+    ! e.g.  UMFPACK, SLU or CUDA stuff.
+    ! We really need FINALs. 
+    if (allocated(lv%sm)) &
+         & call lv%sm%free(info)
 
-  if (allocated(lv%sm2a)) &
-       & call lv%sm2a%free(info)
+    if (allocated(lv%sm2a)) &
+         & call lv%sm2a%free(info)
 
-end subroutine amg_c_base_onelev_free_smoothers
+  end subroutine amg_c_base_onelev_free_smoothers
+end submodule amg_c_base_onelev_dree_smoothers_impl

amgprec/impl/level/amg_c_base_onelev_map_prol.F90

@@ -35,101 +35,113 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
-  use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_map_prol_v
-  
-  implicit none
-  class(amg_c_onelev_type), target, intent(inout) :: lv
-  complex(psb_spk_), intent(in)           :: alpha, beta
-  type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
-  integer(psb_ipk_), intent(out)       :: info
-  complex(psb_spk_), optional          :: work(:)
-  type(psb_c_vect_type), optional, target, intent(inout)  :: vtx,vty
-  
-!!$  write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
-  if (lv%remap_data%ac_pre_remap%is_asb()) then
-    !
-    ! Remap has happened, deal with it
-    !
-!!$    write(0,*) 'Remap handling '
-    block
-      type(psb_ctxt_type) :: ctxt, nctxt
-      integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
-      integer(psb_mpk_) :: me, np,  rme, rnp
-      complex(psb_spk_), allocatable :: rsnd(:), rrcv(:)
-      type(psb_c_vect_type) :: tv
 
-      ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
-      call psb_info(ctxt,me,np)
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_map_prol_impl
+  use psb_base_mod
+  
+contains
+  module subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
+    implicit none
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    complex(psb_spk_), intent(in)           :: alpha, beta
+    type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
+    integer(psb_ipk_), intent(out)       :: info
+    complex(psb_spk_), optional          :: work(:)
+    type(psb_c_vect_type), optional, target, intent(inout)  :: vtx,vty
+
+    type(psb_c_vect_type), pointer   :: vtx_
+
+!!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
+    if (present(vtx)) then
+      vtx_ => vtx
+    else
+      vtx_ => lv%wrk%wv(1)
+    end if
+
+!!$  write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
+    if (lv%remap_data%ac_pre_remap%is_asb()) then
+      !
+      ! Remap has happened, deal with it
+      !
+!!$    write(0,*) 'Remap handling '
+      block
+        type(psb_ctxt_type) :: ctxt, nctxt
+        integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
+        integer(psb_mpk_) :: me, np,  rme, rnp
+complex(psb_spk_), allocatable :: rsnd(:), rrcv(:)
+        type(psb_c_vect_type) :: tv
+
+        ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
+        call psb_info(ctxt,me,np)
 !!$      write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
-      nctxt = lv%desc_ac%get_ctxt()
-      call psb_info(nctxt,rme,rnp)
+        nctxt = lv%desc_ac%get_ctxt()
+        call psb_info(nctxt,rme,rnp)
 !!$      write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
-      idest = lv%remap_data%idest
-      associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
+        idest = lv%remap_data%idest
+        associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
 !!$        write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
-        nsrc = size(isrc)
-        nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
-        nrc  = lv%remap_data%desc_ac_pre_remap%get_local_cols()
-        if (rme >=0) then
-          allocate(rrcv(sum(nrsrc)))
-          rrcv   = vect_v%get_vect()
+          nsrc = size(isrc)
+          nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
+          nrc  = lv%remap_data%desc_ac_pre_remap%get_local_cols()
+          if (rme >=0) then
+            allocate(rrcv(sum(nrsrc)))
+            rrcv   = vect_v%get_vect()
 !!$          write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
-          kp = 0
-          do i = 1,size(isrc)
-            ip = isrc(i)
-            nrl = nrsrc(i)
+            kp = 0
+            do i = 1,size(isrc)
+              ip = isrc(i)
+              nrl = nrsrc(i)
 !!$            write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
-            call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
-            kp = kp + nrl
-          end do
-        end if
-        nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
-        call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
+              call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
+              kp = kp + nrl
+            end do
+          end if
+          nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
+          call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
 !!$        write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
-        
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
+
+          call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
 !!$        write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
 !!$        write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
-        call psb_realloc(nrc,rsnd,info)
-        call psb_rcv(ctxt,rsnd(1:nrl),idest)
-        call tv%set_vect(rsnd)
-        call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
-             & work=work,vtx=vtx,vty=vty)
-      end associate
+!!$        call psb_realloc(nrc,rsnd,info)
+!!$        call psb_rcv(ctxt,rsnd(1:nrl),idest)
+!!$        call tv%set_vect(rsnd)
+          call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
+          call tv%set_host()
+          call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
+               & work=work,vtx=vtx_,vty=vty)
+        end associate
 !!$      write(0,*) me, ' Prolongator with remap done '
 !!$      flush(0)
 !!$      call psb_barrier(ctxt)
-    end block
-  else
-    ! Default transfer
-    call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
-         & work=work,vtx=vtx,vty=vty)
-  end if
-  
-end subroutine amg_c_base_onelev_map_prol_v
+      end block
+    else
+      ! Default transfer
+      call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
+           & work=work,vtx=vtx_,vty=vty)
+    end if
 
-subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
-  use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_map_prol_a
-  implicit none
-  class(amg_c_onelev_type), target, intent(inout) :: lv
-  complex(psb_spk_), intent(in)     :: alpha, beta
-  complex(psb_spk_), intent(inout)   :: u(:)
-  complex(psb_spk_), intent(out)     :: v(:)
-  integer(psb_ipk_), intent(out) :: info
-  complex(psb_spk_), optional          :: work(:)
+  end subroutine amg_c_base_onelev_map_prol_v
 
-  if (lv%remap_data%ac_pre_remap%is_asb()) then
-    !
-    ! Remap has happened, deal with it
-    !
-    write(0,*) 'Remap handling not implemented yet '
-  else
-    ! Default transfer
-    call lv%linmap%map_V2U(alpha,v,beta,u,info,&
-         & work=work)
-  end if
-  
-end subroutine amg_c_base_onelev_map_prol_a
+  module subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+    implicit none
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    complex(psb_spk_), intent(in)     :: alpha, beta
+    complex(psb_spk_), intent(inout)   :: u(:)
+    complex(psb_spk_), intent(out)     :: v(:)
+    integer(psb_ipk_), intent(out) :: info
+    complex(psb_spk_), optional          :: work(:)
+
+    if (lv%remap_data%ac_pre_remap%is_asb()) then
+      !
+      ! Remap has happened, deal with it
+      !
+      write(0,*) 'Remap P handling not implemented yet for A'
+    else
+      ! Default transfer
+      call lv%linmap%map_V2U(alpha,v,beta,u,info,&
+           & work=work)
+    end if
+
+  end subroutine amg_c_base_onelev_map_prol_a
+end submodule amg_c_base_onelev_map_prol_impl

amgprec/impl/level/amg_c_base_onelev_map_rstr.F90

@@ -36,94 +36,115 @@
 !   
 !  
 
-subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
-     &  work,vtx,vty)
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_map_rstr_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_map_rstr_v
-  implicit none
-  class(amg_c_onelev_type), target, intent(inout) :: lv
-  complex(psb_spk_), intent(in)           :: alpha, beta
-  type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
-  integer(psb_ipk_), intent(out)       :: info
-  complex(psb_spk_), optional          :: work(:)
-  type(psb_c_vect_type), optional, target, intent(inout)  :: vtx,vty
+  
+contains
+  module subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
+       &  work,vtx,vty)
+    implicit none
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    complex(psb_spk_), intent(in)           :: alpha, beta
+    type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
+    integer(psb_ipk_), intent(out)       :: info
+    complex(psb_spk_), optional          :: work(:)
+    type(psb_c_vect_type), optional, target, intent(inout)  :: vtx,vty
+    type(psb_c_vect_type), pointer   :: vty_
+    integer(psb_mpk_) :: me, np
 
 !!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-  if (lv%remap_data%ac_pre_remap%is_asb()) then
-    !
-    ! Remap has happened, deal with it
-    !
+    if (present(vty)) then
+      vty_ => vty
+    else
+      vty_ => lv%wrk%wv(1)
+    end if
+
+    if (lv%remap_data%ac_pre_remap%is_asb()) then
+      !
+      ! Remap has happened, deal with it
+      !
 !!$    write(0,*) 'Remap handling not implemented yet '
-    block
-      type(psb_ctxt_type) :: ctxt, nctxt
-      integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
-      integer(psb_mpk_) :: me, np,  rme, rnp
-      complex(psb_spk_), allocatable :: rsnd(:), rrcv(:)
-      type(psb_c_vect_type) :: tv
-      
-      ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
-      call psb_info(ctxt,me,np)
-      nctxt = lv%desc_ac%get_ctxt()
-      call psb_info(nctxt,rme,rnp)
-!!$      write(0,*) 'New context ',rme,rnp
-      idest = lv%remap_data%idest
-      associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
+      block
+        type(psb_ctxt_type) :: ctxt, rctxt
+        integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
+        integer(psb_mpk_) :: rme, rnp
+complex(psb_spk_), allocatable :: rsnd(:), rrcv(:)
+        type(psb_c_vect_type) :: tv
+
+        ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
+        call psb_info(ctxt,me,np)
+        rctxt = lv%desc_ac%get_ctxt()
+        call psb_info(rctxt,rme,rnp)
+!!$      write(0,*) 'New context map rstr',rme,rnp,me,np
+        idest = lv%remap_data%idest
+        associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
 !!$        write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
 !!$        if (rme >= 0) write(0,*) rme, '  Receiving      data from ',isrc(:)
-        nsrc = size(isrc)
-        nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
-        call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
-!!$        write(0,*) me,' Size of TV ',tv%get_nrows()
-        call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
-             & work=work,vtx=vtx,vty=vty)
-        rsnd = tv%get_vect()
-        call psb_snd(ctxt,rsnd(1:nrl),idest)
-        if (rme >=0) then
-          allocate(rrcv(sum(nrsrc)))
+          nsrc = size(isrc)
+          nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
+          call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
+          call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
+!!$        write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),&
+!!$             & psb_errstatus_fatal()
+!!$        flush(0)
+          call psb_barrier(ctxt)
+          call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
+               & work=work,vtx=vtx,vty=vty_)
+          call tv%sync()
+          !rsnd = tv%get_vect()
+          !call psb_snd(ctxt,rsnd(1:nrl),idest) 
+!!$        write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal()
+          call psb_snd(ctxt,tv%v%v(1:nrl),idest)
+          if (rme >=0) then
+            allocate(rrcv(sum(nrsrc)))
 !!$          write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
-          kp = 0
-          do i = 1,size(isrc)
-            ip = isrc(i)
-            nrl = nrsrc(i)
-!!$            write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
-            call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
-            kp = kp + nrl
-          end do
-          call vect_v%set_vect(rrcv)
-        end if
-      end associate
-!!$      write(0,*) me, ' Restrictor with remap done '
-    end block
- 
-  else
-    ! Default transfer
-    call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
-         & work=work,vtx=vtx,vty=vty)
-  end if
-  
-end subroutine amg_c_base_onelev_map_rstr_v
+            kp = 0
+            do i = 1,size(isrc)
+              ip = isrc(i)
+              nrl = nrsrc(i)
+!!$            write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal()           
+              call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
+              kp = kp + nrl
+            end do
+            call vect_v%set_vect(rrcv)
+          end if
+        end associate
+!!$      write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal()     
+      end block
 
-subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
-  use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_map_rstr_a
-  implicit none
-  class(amg_c_onelev_type), target, intent(inout) :: lv
-  complex(psb_spk_), intent(in)     :: alpha, beta
-  complex(psb_spk_), intent(inout)   :: u(:)
-  complex(psb_spk_), intent(out)     :: v(:)
-  integer(psb_ipk_), intent(out) :: info
-  complex(psb_spk_), optional       :: work(:)
+    else
+      ! Default transfer
+      block
+        type(psb_ctxt_type) :: ctxt, rctxt
+        ctxt = lv%linmap%p_desc_U%get_ctxt()
+        call psb_info(ctxt,me,np)
+!!$      write(0,*) me,' map_rstr calling U2V: ',me,np
+        call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
+             & work=work,vtx=vtx,vty=vty_)
+      end block
+    end if
+!!$  write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal()  
+  end subroutine amg_c_base_onelev_map_rstr_v
 
-  if (lv%remap_data%ac_pre_remap%is_asb()) then
-    !
-    ! Remap has happened, deal with it
-    !
-    write(0,*) 'Remap handling not implemented yet '
-  else
-    ! Default transfer
-    call lv%linmap%map_U2V(alpha,u,beta,v,info,&
-         & work=work)
-  end if
-  
-end subroutine amg_c_base_onelev_map_rstr_a
+  module subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+    implicit none
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    complex(psb_spk_), intent(in)     :: alpha, beta
+    complex(psb_spk_), intent(inout)   :: u(:)
+    complex(psb_spk_), intent(out)     :: v(:)
+    integer(psb_ipk_), intent(out) :: info
+    complex(psb_spk_), optional       :: work(:)
+
+    if (lv%remap_data%ac_pre_remap%is_asb()) then
+      !
+      ! Remap has happened, deal with it
+      !
+      write(0,*) 'Remap R handling not implemented yet for A'
+    else
+      ! Default transfer
+      call lv%linmap%map_U2V(alpha,u,beta,v,info,&
+           & work=work)
+    end if
+
+  end subroutine amg_c_base_onelev_map_rstr_a
+end submodule amg_c_base_onelev_map_rstr_impl

amgprec/impl/level/amg_c_base_onelev_mat_asb.f90

@@ -83,109 +83,111 @@
 !    info    -  integer, output.
 !               Error code.         
 !  
-subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
-
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_mat_asb_impl
   use psb_base_mod
   use amg_base_prec_type
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_mat_asb
-
-  implicit none
-
-  ! Arguments
-  class(amg_c_onelev_type), intent(inout), target :: lv
-  type(psb_cspmat_type), intent(in)  :: a
-  type(psb_desc_type), intent(inout)   :: desc_a
-  integer(psb_lpk_), intent(inout) :: nlaggr(:)
-  integer(psb_lpk_), intent(inout) :: ilaggr(:)
-  type(psb_lcspmat_type), intent(inout)  :: t_prol
-  integer(psb_ipk_), intent(out)      :: info
   
+contains
+  module subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
 
-  ! Local variables
-  character(len=24)        :: name
-  type(psb_ctxt_type)      :: ctxt
-  integer(psb_ipk_)        :: np, me
-  integer(psb_ipk_)        :: err_act
-  type(psb_cspmat_type)    :: ac, op_restr, op_prol
-  integer(psb_ipk_)        :: nzl, inl
-  integer(psb_ipk_)        :: debug_level, debug_unit
-  integer(psb_ipk_), save  :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
-  logical, parameter :: do_timings=.false.
+    implicit none
 
-  name='amg_c_onelev_mat_asb'
-  call psb_erractionsave(err_act)
-  if (psb_errstatus_fatal()) then
-    info = psb_err_internal_error_; goto 9999
-  end if
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  info  = psb_success_
-  ctxt = desc_a%get_context()
-  call psb_info(ctxt,me,np)
-  if ((do_timings).and.(idx_matbld==-1))       &
-       & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
-  if ((do_timings).and.(idx_matasb==-1))     &
-       & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
-  if ((do_timings).and.(idx_mapbld==-1))       &
-       & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
-
-  call amg_check_def(lv%parms%aggr_prol,'Smoother',&
-       &   amg_smooth_prol_,is_legal_ml_aggr_prol)
-  call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
-       &   amg_distr_mat_,is_legal_ml_coarse_mat)
-  call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
-       &   amg_no_filter_mat_,is_legal_aggr_filter)
-  call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
-       &   amg_eig_est_,is_legal_ml_aggr_omega_alg)
-  call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
-       &   amg_max_norm_,is_legal_ml_aggr_eig)
-  call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega)
+    ! Arguments
+    class(amg_c_onelev_type), intent(inout), target :: lv
+    type(psb_cspmat_type), intent(in)  :: a
+    type(psb_desc_type), intent(inout)   :: desc_a
+    integer(psb_lpk_), intent(inout) :: nlaggr(:)
+    integer(psb_lpk_), intent(inout) :: ilaggr(:)
+    type(psb_lcspmat_type), intent(inout)  :: t_prol
+    integer(psb_ipk_), intent(out)      :: info
 
 
-  !
-  ! Build the coarse-level matrix from the fine-level one, starting from 
-  ! the mapping defined by amg_aggrmap_bld and applying the aggregation
-  ! algorithm specified by lv%iprcparm(amg_aggr_prol_)
-  !
-  if (do_timings) call psb_tic(idx_matbld)
-  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
-       & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
-  if (do_timings) call psb_toc(idx_matbld)
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
-    goto 9999
-  end if
+    ! Local variables
+    character(len=24)        :: name
+    type(psb_ctxt_type)      :: ctxt
+    integer(psb_ipk_)        :: np, me
+    integer(psb_ipk_)        :: err_act
+    type(psb_cspmat_type)    :: ac, op_restr, op_prol
+    integer(psb_ipk_)        :: nzl, inl
+    integer(psb_ipk_)        :: debug_level, debug_unit
+    integer(psb_ipk_), save  :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
+    logical, parameter :: do_timings=.false.
 
-  !
-  ! Now build its descriptor and convert global indices for
-  ! ac, op_restr and op_prol
-  !
-  if (do_timings) call psb_tic(idx_matasb)
-  if (info == psb_success_) &
-       & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
-       & lv%ac,lv%desc_ac,op_prol,op_restr,info)
-  if (do_timings) call psb_toc(idx_matasb)
-  if (do_timings) call psb_tic(idx_mapbld)  
-  if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
-  
-  if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
-       & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
-  if (do_timings) call psb_toc(idx_mapbld)  
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
-    goto 9999
-  end if
-  !
-  ! Fix the base_a and base_desc pointers for handling of residuals.
-  ! This is correct because this routine is only called at levels >=2.
-  !
-  lv%base_a    => lv%ac
-  lv%base_desc => lv%desc_ac
+    name='amg_c_onelev_mat_asb'
+    call psb_erractionsave(err_act)
+    if (psb_errstatus_fatal()) then
+      info = psb_err_internal_error_; goto 9999
+    end if
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    info  = psb_success_
+    ctxt = desc_a%get_context()
+    call psb_info(ctxt,me,np)
+    if ((do_timings).and.(idx_matbld==-1))       &
+         & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
+    if ((do_timings).and.(idx_matasb==-1))     &
+         & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
+    if ((do_timings).and.(idx_mapbld==-1))       &
+         & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
 
-  call psb_erractionrestore(err_act)
-  return
+    call amg_check_def(lv%parms%aggr_prol,'Smoother',&
+         &   amg_smooth_prol_,is_legal_ml_aggr_prol)
+    call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
+         &   amg_distr_mat_,is_legal_ml_coarse_mat)
+    call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
+         &   amg_no_filter_mat_,is_legal_aggr_filter)
+    call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
+         &   amg_eig_est_,is_legal_ml_aggr_omega_alg)
+    call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
+         &   amg_max_norm_,is_legal_ml_aggr_eig)
+    call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega)
+
+
+    !
+    ! Build the coarse-level matrix from the fine-level one, starting from 
+    ! the mapping defined by amg_aggrmap_bld and applying the aggregation
+    ! algorithm specified by lv%iprcparm(amg_aggr_prol_)
+    !
+    if (do_timings) call psb_tic(idx_matbld)
+    call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
+         & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
+    if (do_timings) call psb_toc(idx_matbld)
+    if(info /= psb_success_) then
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
+      goto 9999
+    end if
+
+    !
+    ! Now build its descriptor and convert global indices for
+    ! ac, op_restr and op_prol
+    !
+    if (do_timings) call psb_tic(idx_matasb)
+    if (info == psb_success_) &
+         & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
+         & lv%ac,lv%desc_ac,op_prol,op_restr,info)
+    if (do_timings) call psb_toc(idx_matasb)
+    if (do_timings) call psb_tic(idx_mapbld)  
+    if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
+
+    if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
+         & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
+    if (do_timings) call psb_toc(idx_mapbld)  
+    if(info /= psb_success_) then
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
+      goto 9999
+    end if
+    !
+    ! Fix the base_a and base_desc pointers for handling of residuals.
+    ! This is correct because this routine is only called at levels >=2.
+    !
+    lv%base_a    => lv%ac
+    lv%base_desc => lv%desc_ac
+
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_c_base_onelev_mat_asb
+  end subroutine amg_c_base_onelev_mat_asb
+end submodule amg_c_base_onelev_mat_asb_impl

amgprec/impl/level/amg_c_base_onelev_memory_use.f90

@@ -42,109 +42,112 @@
 !         0: normal
 !        >1: increased details 
 !
-subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
-
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_memory_use_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_memory_use
-  Implicit None
-  ! Arguments
-  class(amg_c_onelev_type), intent(in)    :: lv
-  integer(psb_ipk_), intent(in)           :: il,nl,ilmin
-  integer(psb_ipk_), intent(out)          :: info
-  integer(psb_ipk_), intent(in), optional :: iout
-  character(len=*), intent(in), optional  :: prefix
-      integer(psb_ipk_), intent(in), optional :: verbosity
-  logical, intent(in), optional           :: global
-
-
-  ! Local variables
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)  :: err_act ,me, np
-  character(len=20), parameter :: name='amg_c_base_onelev_memory_use'
-  integer(psb_ipk_)  :: iout_, verbosity_
-  logical      :: coarse, global_
-  character(1024)    :: prefix_
-  integer(psb_epk_), allocatable  :: sz(:)
-
-
-  call psb_erractionsave(err_act)
-
-  ctxt = lv%base_desc%get_ctxt()
-  call psb_info(ctxt,me,np)
   
-  coarse = (il==nl)
+contains
+  module subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,&
+       & iout,verbosity,prefix,global)
+    Implicit None
+    ! Arguments
+    class(amg_c_onelev_type), intent(in)    :: lv
+    integer(psb_ipk_), intent(in)           :: il,nl,ilmin
+    integer(psb_ipk_), intent(out)          :: info
+    integer(psb_ipk_), intent(in), optional :: iout
+    character(len=*), intent(in), optional  :: prefix
+    integer(psb_ipk_), intent(in), optional :: verbosity
+    logical, intent(in), optional           :: global
 
-  if (present(iout)) then 
-    iout_ = iout
-  else 
-    iout_ = psb_out_unit
-  end if
 
-  if (present(verbosity)) then
-    verbosity_ = verbosity
-  else
-    verbosity_ = 0
-  end if
-  if (verbosity_ < 0) goto 9998
-  if (present(global)) then
-    global_ = global
-  else
-    global_ = .true.
-  end if
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)  :: err_act ,me, np
+    character(len=20), parameter :: name='amg_c_base_onelev_memory_use'
+    integer(psb_ipk_)  :: iout_, verbosity_
+    logical      :: coarse, global_
+    character(1024)    :: prefix_
+    integer(psb_epk_), allocatable  :: sz(:)
 
-  if (present(prefix)) then
-    prefix_ = prefix
-  else
-    prefix_ = ""
-  end if
 
-  if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
+    call psb_erractionsave(err_act)
 
-  if (global_) then
-    allocate(sz(6))
-    sz(:) = 0 
-    sz(1) =  lv%base_a%sizeof()
-    sz(2) =  lv%base_desc%sizeof()
-    if (il >1)              sz(3) =  lv%linmap%sizeof()
-    if (allocated(lv%sm))   sz(4) =  lv%sm%sizeof()
-    if (allocated(lv%sm2a)) sz(5) =  lv%sm2a%sizeof()
-    if (allocated(lv%wrk))  sz(6) =  lv%wrk%sizeof()
-    call psb_sum(ctxt,sz)
-    if (me == 0) then 
-      if (coarse)  then 
-        write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
-      else
-        write(iout_,*) trim(prefix_), ' Level ',il
-      end if
-      write(iout_,*) trim(prefix_), '           Matrix:',                         sz(1) 
-      write(iout_,*) trim(prefix_), '       Descriptor:',                         sz(2) 
-      if (il >1) write(iout_,*) trim(prefix_), '       Linear map:',              sz(3) 
-      if (allocated(lv%sm)) write(iout_,*) trim(prefix_), '         Smoother:',   sz(4) 
-      if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), '       Smoother 2:', sz(5) 
-      if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), '        Workspace:',  sz(6)
+    ctxt = lv%base_desc%get_ctxt()
+    call psb_info(ctxt,me,np)
+
+    coarse = (il==nl)
+
+    if (present(iout)) then 
+      iout_ = iout
+    else 
+      iout_ = psb_out_unit
     end if
-    
-  else
-    if ((me == 0).or.(verbosity_>0)) then 
-      if (coarse)  then 
-        write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
-      else
-        write(iout_,*) trim(prefix_), ' Level ',il
-      end if
-      write(iout_,*) trim(prefix_), '           Matrix:', lv%base_a%sizeof()
-      write(iout_,*) trim(prefix_), '       Descriptor:', lv%base_desc%sizeof()
-      if (il >1) write(iout_,*) trim(prefix_), '       Linear map:', lv%linmap%sizeof()
-      if (allocated(lv%sm)) write(iout_,*) trim(prefix_), '         Smoother:', lv%sm%sizeof()
-      if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), '       Smoother 2:', lv%sm2a%sizeof()
-      if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), '        Workspace:', lv%wrk%sizeof()
+
+    if (present(verbosity)) then
+      verbosity_ = verbosity
+    else
+      verbosity_ = 0
     end if
-  endif
+    if (verbosity_ < 0) goto 9998
+    if (present(global)) then
+      global_ = global
+    else
+      global_ = .true.
+    end if
+
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
+
+    if (global_) then
+      allocate(sz(6))
+      sz(:) = 0 
+      sz(1) =  lv%base_a%sizeof()
+      sz(2) =  lv%base_desc%sizeof()
+      if (il >1)              sz(3) =  lv%linmap%sizeof()
+      if (allocated(lv%sm))   sz(4) =  lv%sm%sizeof()
+      if (allocated(lv%sm2a)) sz(5) =  lv%sm2a%sizeof()
+      if (allocated(lv%wrk))  sz(6) =  lv%wrk%sizeof()
+      call psb_sum(ctxt,sz)
+      if (me == 0) then 
+        if (coarse)  then 
+          write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
+        else
+          write(iout_,*) trim(prefix_), ' Level ',il
+        end if
+        write(iout_,*) trim(prefix_), '           Matrix:',                         sz(1) 
+        write(iout_,*) trim(prefix_), '       Descriptor:',                         sz(2) 
+        if (il >1) write(iout_,*) trim(prefix_), '       Linear map:',              sz(3) 
+        if (allocated(lv%sm)) write(iout_,*) trim(prefix_), '         Smoother:',   sz(4) 
+        if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), '       Smoother 2:', sz(5) 
+        if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), '        Workspace:',  sz(6)
+      end if
+
+    else
+      if ((me == 0).or.(verbosity_>0)) then 
+        if (coarse)  then 
+          write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
+        else
+          write(iout_,*) trim(prefix_), ' Level ',il
+        end if
+        write(iout_,*) trim(prefix_), '           Matrix:', lv%base_a%sizeof()
+        write(iout_,*) trim(prefix_), '       Descriptor:', lv%base_desc%sizeof()
+        if (il >1) write(iout_,*) trim(prefix_), '       Linear map:', lv%linmap%sizeof()
+        if (allocated(lv%sm)) write(iout_,*) trim(prefix_), '         Smoother:', lv%sm%sizeof()
+        if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), '       Smoother 2:', lv%sm2a%sizeof()
+        if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), '        Workspace:', lv%wrk%sizeof()
+      end if
+    endif
 
 9998 continue
-  call psb_erractionrestore(err_act)
-  return
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_c_base_onelev_memory_use
+  end subroutine amg_c_base_onelev_memory_use
+end submodule amg_c_base_onelev_memory_use_impl

amgprec/impl/level/amg_c_base_onelev_setag.f90

@@ -35,48 +35,50 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_setag(lv,val,info,pos)
-
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_setag_impl
   use psb_base_mod
-  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_setag
-
-  implicit none
-
-  ! Arguments
-  class(amg_c_onelev_type), target, intent(inout) :: lv
-  class(amg_c_base_aggregator_type), intent(in)   :: val
-  integer(psb_ipk_), intent(out)                  :: info
-  character(len=*), optional, intent(in)          :: pos
   
-  ! Local variables
-  integer(psb_ipk_)                :: ipos_
-  character(len=*), parameter      :: name='amg_base_onelev_setag'
+contains
+  module subroutine amg_c_base_onelev_setag(lv,val,info,pos)
 
-  info = psb_success_
+    implicit none
 
-  ! Ignore pos for aggregator
-  
-  if (allocated(lv%aggr)) then 
-    if (.not.same_type_as(lv%aggr,val))  then
-      call lv%aggr%free(info)
-      deallocate(lv%aggr,stat=info)
+    ! Arguments
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    class(amg_c_base_aggregator_type), intent(in)   :: val
+    integer(psb_ipk_), intent(out)                  :: info
+    character(len=*), optional, intent(in)          :: pos
+
+    ! Local variables
+    integer(psb_ipk_)                :: ipos_
+    character(len=*), parameter      :: name='amg_base_onelev_setag'
+
+    info = psb_success_
+
+    ! Ignore pos for aggregator
+
+    if (allocated(lv%aggr)) then 
+      if (.not.same_type_as(lv%aggr,val))  then
+        call lv%aggr%free(info)
+        deallocate(lv%aggr,stat=info)
+        if (info /= 0) then
+          info = 3111
+          return
+        end if
+      end if
+    end if
+
+    if (.not.allocated(lv%aggr)) then 
+      allocate(lv%aggr,mold=val,stat=info) 
       if (info /= 0) then
         info = 3111
         return
       end if
+      lv%parms%par_aggr_alg  = amg_ext_aggr_
+      lv%parms%aggr_type     = amg_noalg_
+      call lv%aggr%default()
     end if
-  end if
-      
-  if (.not.allocated(lv%aggr)) then 
-    allocate(lv%aggr,mold=val,stat=info) 
-    if (info /= 0) then
-      info = 3111
-      return
-    end if
-    lv%parms%par_aggr_alg  = amg_ext_aggr_
-    lv%parms%aggr_type     = amg_noalg_
-    call lv%aggr%default()
-  end if
-  
-end subroutine amg_c_base_onelev_setag
 
+  end subroutine amg_c_base_onelev_setag
+
+end submodule amg_c_base_onelev_setag_impl

amgprec/impl/level/amg_c_base_onelev_setsm.F90

@@ -35,72 +35,73 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_setsm(lev,val,info,pos)
-
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_setsm_impl
   use psb_base_mod
-  use amg_c_prec_mod, amg_protect_name => amg_c_base_onelev_setsm
-
-  implicit none
-
-  ! Arguments
-  class(amg_c_onelev_type), target, intent(inout) :: lev
-  class(amg_c_base_smoother_type), intent(in)  :: val
-  integer(psb_ipk_), intent(out)               :: info
-  character(len=*), optional, intent(in)       :: pos
   
-  ! Local variables
-  integer(psb_ipk_)                      :: ipos_
-  character(len=*), parameter            :: name='amg_base_onelev_setsm'
-  
-  info = psb_success_
+contains
+  module subroutine amg_c_base_onelev_setsm(lv,val,info,pos)
+    implicit none
 
-  if (present(pos)) then
-    select case(psb_toupper(trim(pos)))
-    case('PRE')
-      ipos_ = amg_smooth_pre_
-    case('POST')
-      ipos_ = amg_smooth_post_
-    case default
+    ! Arguments
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    class(amg_c_base_smoother_type), intent(in)  :: val
+    integer(psb_ipk_), intent(out)               :: info
+    character(len=*), optional, intent(in)       :: pos
+
+    ! Local variables
+    integer(psb_ipk_)                      :: ipos_
+    character(len=*), parameter            :: name='amg_base_onelev_setsm'
+
+    info = psb_success_
+
+    if (present(pos)) then
+      select case(psb_toupper(trim(pos)))
+      case('PRE')
+        ipos_ = amg_smooth_pre_
+      case('POST')
+        ipos_ = amg_smooth_post_
+      case default
+        ipos_ = amg_smooth_both_
+      end select
+    else
       ipos_ = amg_smooth_both_
-    end select
-  else
-    ipos_ = amg_smooth_both_
-  end if
-
-  if (ipos_ == amg_smooth_both_) then
-    if (allocated(lev%sm2a)) then
-      call lev%sm2a%free(info)
-      deallocate(lev%sm2a, stat=info)
-      lev%sm2 => null()
     end if
-  end if
-     
-  select case(ipos_)
-  case(amg_smooth_pre_, amg_smooth_both_) 
-    if (allocated(lev%sm)) then
-      if (.not.same_type_as(lev%sm,val)) then
-        call lev%sm%free(info)
-        deallocate(lev%sm, stat=info)
+
+    if (ipos_ == amg_smooth_both_) then
+      if (allocated(lv%sm2a)) then
+        call lv%sm2a%free(info)
+        deallocate(lv%sm2a, stat=info)
+        lv%sm2 => null()
       end if
-    endif
-    if (.not.allocated(lev%sm)) then
-      allocate(lev%sm,mold=val) 
     end if
-    call lev%sm%default()        
-    if (ipos_ ==  amg_smooth_both_) lev%sm2 => lev%sm
-  case(amg_smooth_post_) 
-    if (allocated(lev%sm2a)) then
-      if (.not.same_type_as(lev%sm2a,val)) then
-        call lev%sm2a%free(info)
-        deallocate(lev%sm2a, stat=info)
-      endif
-    end if
-    if (.not.allocated(lev%sm2a)) then
-      allocate(lev%sm2a,mold=val) 
-    end if
-    call lev%sm2a%default()
-    lev%sm2 => lev%sm2a
-  end select
-    
-end subroutine amg_c_base_onelev_setsm
 
+    select case(ipos_)
+    case(amg_smooth_pre_, amg_smooth_both_) 
+      if (allocated(lv%sm)) then
+        if (.not.same_type_as(lv%sm,val)) then
+          call lv%sm%free(info)
+          deallocate(lv%sm, stat=info)
+        end if
+      endif
+      if (.not.allocated(lv%sm)) then
+        allocate(lv%sm,mold=val) 
+      end if
+      call lv%sm%default()        
+      if (ipos_ ==  amg_smooth_both_) lv%sm2 => lv%sm
+    case(amg_smooth_post_) 
+      if (allocated(lv%sm2a)) then
+        if (.not.same_type_as(lv%sm2a,val)) then
+          call lv%sm2a%free(info)
+          deallocate(lv%sm2a, stat=info)
+        endif
+      end if
+      if (.not.allocated(lv%sm2a)) then
+        allocate(lv%sm2a,mold=val) 
+      end if
+      call lv%sm2a%default()
+      lv%sm2 => lv%sm2a
+    end select
+
+  end subroutine amg_c_base_onelev_setsm
+
+end submodule amg_c_base_onelev_setsm_impl

amgprec/impl/level/amg_c_base_onelev_setsv.F90

@@ -35,110 +35,111 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_c_base_onelev_setsv(lev,val,info,pos)
-
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_setsv_impl
   use psb_base_mod
-  use amg_c_prec_mod, amg_protect_name => amg_c_base_onelev_setsv
-
-  implicit none
-
-  ! Arguments
-  class(amg_c_onelev_type), target, intent(inout) :: lev
-  class(amg_c_base_solver_type), intent(in)       :: val
-  integer(psb_ipk_), intent(out)                  :: info
-  character(len=*), optional, intent(in)          :: pos
   
-  ! Local variables
-  integer(psb_ipk_)                :: ipos_
-  character(len=*), parameter      :: name='amg_base_onelev_setsv'
+contains
+  module subroutine amg_c_base_onelev_setsv(lv,val,info,pos)
+    implicit none
 
-  info = psb_success_
+    ! Arguments
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    class(amg_c_base_solver_type), intent(in)       :: val
+    integer(psb_ipk_), intent(out)                  :: info
+    character(len=*), optional, intent(in)          :: pos
 
-  if (present(pos)) then
-    select case(psb_toupper(trim(pos)))
-    case('PRE')
-      ipos_ = amg_smooth_pre_
-    case('POST')
-      ipos_ = amg_smooth_post_
-    case default
+    ! Local variables
+    integer(psb_ipk_)                :: ipos_
+    character(len=*), parameter      :: name='amg_base_onelev_setsv'
+
+    info = psb_success_
+
+    if (present(pos)) then
+      select case(psb_toupper(trim(pos)))
+      case('PRE')
+        ipos_ = amg_smooth_pre_
+      case('POST')
+        ipos_ = amg_smooth_post_
+      case default
+        ipos_ = amg_smooth_both_
+      end select
+    else
       ipos_ = amg_smooth_both_
-    end select
-  else
-    ipos_ = amg_smooth_both_
-  end if
-  
-  if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then 
-    if (allocated(lev%sm)) then 
-      if (allocated(lev%sm%sv)) then
-        if (.not.same_type_as(lev%sm%sv,val))  then
-          call lev%sm%sv%free(info)
-          if (info == 0) deallocate(lev%sm%sv,stat=info)
+    end if
+
+    if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then 
+      if (allocated(lv%sm)) then 
+        if (allocated(lv%sm%sv)) then
+          if (.not.same_type_as(lv%sm%sv,val))  then
+            call lv%sm%sv%free(info)
+            if (info == 0) deallocate(lv%sm%sv,stat=info)
+            if (info /= 0) then
+              info = 3111
+              return
+            end if
+          end if
+        end if
+
+        if (.not.allocated(lv%sm%sv)) then 
+          allocate(lv%sm%sv,mold=val,stat=info) 
           if (info /= 0) then
             info = 3111
             return
           end if
         end if
+        call lv%sm%sv%default()
+      else
+        info = 3111
+        write(psb_err_unit,*) name,&
+             &': Error: uninitialized preconditioner component,',&
+             &' should call amg_PRECINIT/amg_PRECSET' 
+        return 
+
       end if
-      
-      if (.not.allocated(lev%sm%sv)) then 
-        allocate(lev%sm%sv,mold=val,stat=info) 
-        if (info /= 0) then
-          info = 3111
-          return
-        end if
-      end if
-      call lev%sm%sv%default()
-    else
-      info = 3111
-      write(psb_err_unit,*) name,&
-           &': Error: uninitialized preconditioner component,',&
-           &' should call amg_PRECINIT/amg_PRECSET' 
-      return 
-      
     end if
-  end if
 
-  !
-  ! If POS was not specified and therefore we have amg_smooth_both_
-  ! we need to update sm2a *only* if it was already allocated,
-  ! otherwise it is not needed (since we have just fixed %sm in the
-  ! pre section). 
-  !
+    !
+    ! If POS was not specified and therefore we have amg_smooth_both_
+    ! we need to update sm2a *only* if it was already allocated,
+    ! otherwise it is not needed (since we have just fixed %sm in the
+    ! pre section). 
+    !
 
-  if ((ipos_ == amg_smooth_post_).or. &
-       ((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then 
+    if ((ipos_ == amg_smooth_post_).or. &
+         ((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then 
 
 
-    if (allocated(lev%sm2a)) then 
-      if (allocated(lev%sm2a%sv)) then
-        if (.not.same_type_as(lev%sm2a%sv,val))  then
-          call lev%sm2a%sv%free(info)
-          if (info == 0) deallocate(lev%sm2a%sv,stat=info)
+      if (allocated(lv%sm2a)) then 
+        if (allocated(lv%sm2a%sv)) then
+          if (.not.same_type_as(lv%sm2a%sv,val))  then
+            call lv%sm2a%sv%free(info)
+            if (info == 0) deallocate(lv%sm2a%sv,stat=info)
+            if (info /= 0) then
+              info = 3111
+              return
+            end if
+          end if
+        end if
+        if (.not.allocated(lv%sm2a%sv)) then 
+          allocate(lv%sm2a%sv,mold=val,stat=info) 
           if (info /= 0) then
             info = 3111
             return
           end if
         end if
-      end if
-      if (.not.allocated(lev%sm2a%sv)) then 
-        allocate(lev%sm2a%sv,mold=val,stat=info) 
-        if (info /= 0) then
-          info = 3111
-          return
-        end if
-      end if
-      call lev%sm2a%sv%default()
-      
-    else
-      info = 3111
-      write(psb_err_unit,*) name,&
-           &': Error: uninitialized preconditioner component,',&
-           &' should call amg_PRECINIT/amg_PRECSET' 
-      return 
-      
-    end if
-    
-  end if
-  
-end subroutine amg_c_base_onelev_setsv
+        call lv%sm2a%sv%default()
 
+      else
+        info = 3111
+        write(psb_err_unit,*) name,&
+             &': Error: uninitialized preconditioner component,',&
+             &' should call amg_PRECINIT/amg_PRECSET' 
+        return 
+
+      end if
+
+    end if
+
+  end subroutine amg_c_base_onelev_setsv
+
+end submodule amg_c_base_onelev_setsv_impl

amgprec/impl/level/amg_c_base_onelev_wrk_handle.f90

@@ -0,0 +1,333 @@
+!  
+!   
+!                             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 prior written permission.
+!   
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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.
+!   
+!  
+submodule (amg_c_onelev_mod)  amg_c_base_onelev_wrk_handle_impl
+  use psb_base_mod
+  
+contains
+  
+  module subroutine c_base_onelev_move_alloc(lv, b,info)
+    implicit none
+    class(amg_c_onelev_type), target, intent(inout) :: lv, b
+    integer(psb_ipk_), intent(out) :: info
+
+    call b%free(info)
+    b%parms  = lv%parms
+    b%szratio = lv%szratio
+    if (associated(lv%sm2,lv%sm2a)) then
+      call move_alloc(lv%sm,b%sm)
+      call move_alloc(lv%sm2a,b%sm2a)
+      b%sm2 =>b%sm2a
+    else
+      call move_alloc(lv%sm,b%sm)
+      call move_alloc(lv%sm2a,b%sm2a)
+      b%sm2 =>b%sm
+    end if
+
+    call move_alloc(lv%aggr,b%aggr)
+    if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
+    if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
+    if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
+    if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
+    if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
+    b%base_a    => lv%base_a
+    b%base_desc => lv%base_desc
+
+  end subroutine c_base_onelev_move_alloc
+
+  module subroutine c_base_onelev_allocate_wrk(lv,info,vmold)
+    implicit none
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    integer(psb_ipk_), intent(out) :: info
+    class(psb_c_base_vect_type), intent(in), optional  :: vmold
+    !
+    integer(psb_ipk_) :: nwv, i
+    info = psb_success_
+    nwv = lv%get_wrksz()
+    if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
+!!$    write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
+    if (info == 0) then
+      if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
+        !
+        !  Need to fix this, we need two different allocations
+        !
+        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
+             & desc2=lv%remap_data%desc_ac_pre_remap)
+      else
+        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
+      end if
+    end if
+
+  end subroutine c_base_onelev_allocate_wrk
+
+  module subroutine c_base_onelev_free_wrk(lv,info)
+    implicit none
+    class(amg_c_onelev_type), target, intent(inout) :: lv
+    integer(psb_ipk_), intent(out) :: info
+    !
+    integer(psb_ipk_) :: nwv,i
+    info = psb_success_
+
+    if (allocated(lv%wrk)) then
+      call lv%wrk%free(info)
+      if (info == 0) deallocate(lv%wrk,stat=info)
+    end if
+  end subroutine c_base_onelev_free_wrk
+
+  module subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
+    Implicit None
+    ! Arguments
+    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+    integer(psb_ipk_), intent(in)                     :: nwv
+    type(psb_desc_type), intent(in)                   :: desc
+    integer(psb_ipk_), intent(out)                    :: info
+    class(psb_c_base_vect_type), intent(in), optional  :: vmold
+    type(psb_desc_type), intent(in), optional          :: desc2
+    !
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+    call wk%free(info)
+!!$    write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
+!!$         & present(desc2),desc%is_valid()
+
+    allocate(wk%wv(nwv),stat=info)    
+    if  (present(desc2).and.(desc%is_valid())) then
+!!$      write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
+      if (desc2%get_local_cols()>desc%get_local_cols()) then
+        call c_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
+      else
+        call c_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
+      end if
+    else if (present(desc2)) then
+      call c_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
+    else if (desc%is_valid()) then
+      call c_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)      
+    end if
+
+  contains
+  end subroutine c_wrk_alloc
+
+  module subroutine c_inner_do_wrk_alloc(wk,nwv,desc,vmold)
+    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+    integer(psb_ipk_), intent(in)                     :: nwv
+    type(psb_desc_type), intent(in)                   :: desc
+    class(psb_c_base_vect_type), intent(in), optional  :: vmold
+    
+    integer(psb_ipk_) :: i
+    
+    call psb_geasb(wk%vx2l,desc,info,&
+         & scratch=.true.,mold=vmold)
+    call psb_geasb(wk%vy2l,desc,info,&
+         & scratch=.true.,mold=vmold)
+    call psb_geasb(wk%vtx,desc,info,&
+         & scratch=.true.,mold=vmold)
+    call psb_geasb(wk%vty,desc,info,&
+         & scratch=.true.,mold=vmold)
+    do i=1,nwv
+      call psb_geasb(wk%wv(i),desc,info,&
+           & scratch=.true.,mold=vmold)
+    end do
+  end subroutine c_inner_do_wrk_alloc
+  
+  
+  module subroutine c_wrk_free(wk,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+    integer(psb_ipk_), intent(out)                    :: info
+    !
+    integer(psb_ipk_) :: i
+    info = psb_success_
+
+    if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
+    if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
+    if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
+    if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
+    call wk%vtx%free(info)
+    call wk%vty%free(info)
+    call wk%vx2l%free(info)
+    call wk%vy2l%free(info)
+    if (allocated(wk%wv)) then
+      do i=1,size(wk%wv)
+        call wk%wv(i)%free(info)
+      end do
+      deallocate(wk%wv, stat=info)
+    end if
+
+  end subroutine c_wrk_free
+
+  module subroutine c_wrk_clone(wk,wkout,info)
+    Implicit None
+
+    ! Arguments
+    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+    class(amg_cmlprec_wrk_type), target, intent(inout) :: wkout
+    integer(psb_ipk_), intent(out)                    :: info
+    !
+    integer(psb_ipk_) :: i
+    info = psb_success_
+
+    call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
+    call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
+    call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
+    call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
+    call wk%vtx%clone(wkout%vtx,info)
+    call wk%vty%clone(wkout%vty,info)
+    call wk%vx2l%clone(wkout%vx2l,info)
+    call wk%vy2l%clone(wkout%vy2l,info)
+    if (allocated(wkout%wv)) then
+      do i=1,size(wkout%wv)
+        call wkout%wv(i)%free(info)
+      end do
+      deallocate( wkout%wv)
+    end if
+    allocate(wkout%wv(size(wk%wv)),stat=info)
+    do i=1,size(wk%wv)
+      call wk%wv(i)%clone(wkout%wv(i),info)
+    end do
+    return
+
+  end subroutine c_wrk_clone
+
+  module subroutine c_wrk_move_alloc(wk, b,info)
+    implicit none
+    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk, b
+    integer(psb_ipk_), intent(out) :: info
+
+    call b%free(info)
+    call move_alloc(wk%tx,b%tx)
+    call move_alloc(wk%ty,b%ty)
+    call move_alloc(wk%x2l,b%x2l)
+    call move_alloc(wk%y2l,b%y2l)
+    !
+    ! Should define V%move_alloc....
+    call move_alloc(wk%vtx%v,b%vtx%v)
+    call move_alloc(wk%vty%v,b%vty%v)
+    call move_alloc(wk%vx2l%v,b%vx2l%v)
+    call move_alloc(wk%vy2l%v,b%vy2l%v)
+    call move_alloc(wk%wv,b%wv)
+
+  end subroutine c_wrk_move_alloc
+
+  module subroutine c_wrk_cnv(wk,info,vmold)
+    Implicit None
+
+    ! Arguments
+    class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
+    integer(psb_ipk_), intent(out)                    :: info
+    class(psb_c_base_vect_type), intent(in), optional  :: vmold
+    !
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+    if (present(vmold)) then
+      call wk%vtx%cnv(vmold)
+      call wk%vty%cnv(vmold)
+      call wk%vx2l%cnv(vmold)
+      call wk%vy2l%cnv(vmold)
+      if (allocated(wk%wv)) then
+        do i=1,size(wk%wv)
+          call wk%wv(i)%cnv(vmold)
+        end do
+      end if
+    end if
+  end subroutine c_wrk_cnv
+
+  module function c_wrk_sizeof(wk) result(val)
+    implicit none
+    class(amg_cmlprec_wrk_type), intent(in) :: wk
+    integer(psb_epk_) :: val
+    integer :: i
+    val = 0
+    val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%tx)
+    val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%ty)
+    val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%x2l)
+    val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%y2l)
+    val = val + wk%vtx%sizeof()
+    val = val + wk%vty%sizeof()
+    val = val + wk%vx2l%sizeof()
+    val = val + wk%vy2l%sizeof()
+    if (allocated(wk%wv)) then
+      do i=1, size(wk%wv)
+        val = val + wk%wv(i)%sizeof()
+      end do
+    end if
+  end function c_wrk_sizeof
+
+  module subroutine c_remap_data_clone(rmp, remap_out, info)
+    implicit none
+    ! Arguments
+    class(amg_c_remap_data_type), target, intent(inout) :: rmp
+    class(amg_c_remap_data_type), target, intent(inout) :: remap_out
+    integer(psb_ipk_), intent(out)                    :: info
+    !
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+
+    call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
+    if (info == psb_success_) &
+         & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
+    remap_out%idest = rmp%idest
+    call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
+    call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
+  end subroutine c_remap_data_clone
+
+  module subroutine c_remap_move_alloc(rmp, remap_out, info)
+    implicit none
+    ! Arguments
+    class(amg_c_remap_data_type), target, intent(inout) :: rmp
+    class(amg_c_remap_data_type), target, intent(inout) :: remap_out
+    integer(psb_ipk_), intent(out)                    :: info
+    !
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+
+    call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
+    if (info == psb_success_) &
+         & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
+    remap_out%idest = rmp%idest
+    call move_alloc(rmp%isrc,remap_out%isrc)
+    call move_alloc(rmp%nrsrc,remap_out%nrsrc)
+    call move_alloc(rmp%naggr,remap_out%naggr)
+  end subroutine c_remap_move_alloc
+  
+end submodule amg_c_base_onelev_wrk_handle_impl

amgprec/impl/level/amg_d_base_onelev_build.f90

@@ -35,129 +35,132 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_build_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_build
-  implicit none
-  class(amg_d_onelev_type), target, intent(inout) :: lv
-  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
-  integer(psb_ipk_), intent(in), optional :: ilv
-  ! Local
-  integer(psb_ipk_)   :: err,i,k, err_act
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: me, np
-  integer(psb_ipk_)   :: debug_level, debug_unit
-  character(len=20)   :: name, ch_err
+  
+contains
+  module  subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+    implicit none
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    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
+    integer(psb_ipk_), intent(in), optional :: ilv
+    ! Local
+    integer(psb_ipk_)   :: err,i,k, err_act
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: me, np
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    character(len=20)   :: name, ch_err
 
-  name = 'amg_onelev_build'
-  info=psb_success_
-  err=0
-  call psb_erractionsave(err_act)
-  if (psb_errstatus_fatal()) then
-    info = psb_err_internal_error_; goto 9999
-  end if
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  if (.not.associated(lv%base_desc)) then
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,&
-         & a_err='Unassociated base DESC')
-    goto 9999
-  end if
-  info = psb_success_
-  ctxt = lv%base_desc%get_ctxt()
-  call psb_info(ctxt,me,np)
-
-  !
-  ! At top level(s) I may be using
-  ! a context with less processes
-  !
-  if (me < 0) then
-!!$    write(0,*) 'onelevbld: I am excluded from this one '
-  else
-!!$    write(0,*) me,' Going to build smoothers at this level '
-    if (.not.allocated(lv%sm)) then 
-      !! Error: should have called amg_dprecinit
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
+    name = 'amg_onelev_build'
+    info=psb_success_
+    err=0
+    call psb_erractionsave(err_act)
+    if (psb_errstatus_fatal()) then
+      info = psb_err_internal_error_; goto 9999
     end if
-    if (.not.allocated(lv%sm%sv)) then 
-      !! Error: should have called amg_dprecinit
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-    lv%ac_nz_loc = lv%ac%get_nzeros()
-    lv%ac_nz_tot = lv%ac_nz_loc
-    select case(lv%parms%coarse_mat)
-    case(amg_distr_mat_) 
-      call psb_sum(ctxt,lv%ac_nz_tot)
-    case(amg_repl_mat_)
-      ! Do nothing
-    case default
-      ! Should never get here
-      info = psb_err_internal_error_
-      call psb_errpush(info,name,a_err='Wrong lv%parms')
-      goto 9999
-    end select
-    
-    
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Calling mlprcbld at level  ',i
-    call amg_check_def(lv%parms%sweeps_pre,&
-         & 'Jacobi sweeps',izero,is_int_non_negative)
-    call amg_check_def(lv%parms%sweeps_post,&
-         & 'Jacobi sweeps',izero,is_int_non_negative)
-    
-    call lv%sm%build(lv%base_a,lv%base_desc,info)
-    if (info == 0) then
-      if (allocated(lv%sm2a)) then 
-        call lv%sm2a%build(lv%base_a,lv%base_desc,info)
-        lv%sm2 => lv%sm2a
-      else
-        lv%sm2 => lv%sm
-      end if
-    end if
-    if (info /=0 ) then
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    if (.not.associated(lv%base_desc)) then
       info = psb_err_internal_error_
       call psb_errpush(info,name,&
-           & a_err='Smoother bld error')
+           & a_err='Unassociated base DESC')
       goto 9999
     end if
-    
-    if (lv%sm%sv%is_global()) then
-      if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
-        lv%parms%sweeps_pre  = 1
-        lv%parms%sweeps_post = 1
-        if (me == 0) then
-          write(debug_unit,*) 
-          if (present(ilv)) then
-            write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
-                 & '" at level ',ilv
-            write(debug_unit,*) '         is configured as a global solver '
-          else
-            write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
-                 & '" is configured as a global solver '
+    info = psb_success_
+    ctxt = lv%base_desc%get_ctxt()
+    call psb_info(ctxt,me,np)
+
+    !
+    ! At top level(s) I may be using
+    ! a context with less processes
+    !
+    if (me < 0) then
+!!$    write(0,*) 'onelevbld: I am excluded from this one '
+    else
+!!$    write(0,*) me,' Going to build smoothers at this level '
+      if (.not.allocated(lv%sm)) then 
+        !! Error: should have called amg_dprecinit
+        info=3111
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+      if (.not.allocated(lv%sm%sv)) then 
+        !! Error: should have called amg_dprecinit
+        info=3111
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+      lv%ac_nz_loc = lv%ac%get_nzeros()
+      lv%ac_nz_tot = lv%ac_nz_loc
+      select case(lv%parms%coarse_mat)
+      case(amg_distr_mat_) 
+        call psb_sum(ctxt,lv%ac_nz_tot)
+      case(amg_repl_mat_)
+        ! Do nothing
+      case default
+        ! Should never get here
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,a_err='Wrong lv%parms')
+        goto 9999
+      end select
+
+
+      if (debug_level >= psb_debug_outer_) &
+           & write(debug_unit,*) me,' ',trim(name),&
+           & 'Calling mlprcbld at level  ',i
+      call amg_check_def(lv%parms%sweeps_pre,&
+           & 'Jacobi sweeps',izero,is_int_non_negative)
+      call amg_check_def(lv%parms%sweeps_post,&
+           & 'Jacobi sweeps',izero,is_int_non_negative)
+
+      call lv%sm%build(lv%base_a,lv%base_desc,info)
+      if (info == 0) then
+        if (allocated(lv%sm2a)) then 
+          call lv%sm2a%build(lv%base_a,lv%base_desc,info)
+          lv%sm2 => lv%sm2a
+        else
+          lv%sm2 => lv%sm
+        end if
+      end if
+      if (info /=0 ) then
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,&
+             & a_err='Smoother bld error')
+        goto 9999
+      end if
+
+      if (lv%sm%sv%is_global()) then
+        if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
+          lv%parms%sweeps_pre  = 1
+          lv%parms%sweeps_post = 1
+          if (me == 0) then
+            write(debug_unit,*) 
+            if (present(ilv)) then
+              write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
+                   & '" at level ',ilv
+              write(debug_unit,*) '         is configured as a global solver '
+            else
+              write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
+                   & '" is configured as a global solver '
+            end if
+            write(debug_unit,*) '        Pre and post sweeps at this level reset to 1'
           end if
-          write(debug_unit,*) '        Pre and post sweeps at this level reset to 1'
         end if
       end if
     end if
-  end if
-  
-  if (any((/present(amold),present(vmold),present(imold)/))) &
-       & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
 
-  call psb_erractionrestore(err_act)
-  return
+    if (any((/present(amold),present(vmold),present(imold)/))) &
+         & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
+
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
 
-  return
+    return
 
-end subroutine amg_d_base_onelev_build
+  end subroutine amg_d_base_onelev_build
+end submodule amg_d_base_onelev_build_impl

amgprec/impl/level/amg_d_base_onelev_check.f90

@@ -35,59 +35,60 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_check(lv,info)
-  
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_check_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_check
-
-  Implicit None
-
-  ! Arguments
-  class(amg_d_onelev_type), intent(inout) :: lv 
-  integer(psb_ipk_), intent(out)            :: info
-  integer(psb_ipk_)           :: err_act
-  character(len=20) :: name='d_base_onelev_check'
-
-  call psb_erractionsave(err_act)
-  info = psb_success_
-
-  call amg_check_def(lv%parms%sweeps_pre,&
-       & 'Jacobi sweeps',ione,is_int_non_negative)
-  call amg_check_def(lv%parms%sweeps_post,&
-       & 'Jacobi sweeps',ione,is_int_non_negative)
-
-  if (allocated(lv%sm)) then 
-    call lv%sm%check(info)
-  else 
-    info=3111
-    call psb_errpush(info,name)
-    goto 9999
-  end if
-
-  if (allocated(lv%sm2a)) then 
-    call lv%sm2a%check(info)
-  else if (.not.inner_check(lv%sm2,lv%sm)) then 
-    info=3111
-    call psb_errpush(info,name)
-    goto 9999
-  end if
-
-  if (info /= psb_success_) goto 9999
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-  return
 
 contains
-  function inner_check(smp,sm) result(res)
-    implicit none
-    logical :: res
-    class(amg_d_base_smoother_type), intent(in), pointer :: smp 
-    class(amg_d_base_smoother_type), intent(in), target  :: sm
+  module subroutine amg_d_base_onelev_check(lv,info)
+    Implicit None
 
-    res = associated(smp, sm)
-  end function inner_check
-  
-end subroutine amg_d_base_onelev_check
+    ! Arguments
+    class(amg_d_onelev_type), intent(inout) :: lv 
+    integer(psb_ipk_), intent(out)            :: info
+    integer(psb_ipk_)           :: err_act
+    character(len=20) :: name='d_base_onelev_check'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call amg_check_def(lv%parms%sweeps_pre,&
+         & 'Jacobi sweeps',ione,is_int_non_negative)
+    call amg_check_def(lv%parms%sweeps_post,&
+         & 'Jacobi sweeps',ione,is_int_non_negative)
+
+    if (allocated(lv%sm)) then 
+      call lv%sm%check(info)
+    else 
+      info=3111
+      call psb_errpush(info,name)
+      goto 9999
+    end if
+
+    if (allocated(lv%sm2a)) then 
+      call lv%sm2a%check(info)
+    else if (.not.inner_check(lv%sm2,lv%sm)) then 
+      info=3111
+      call psb_errpush(info,name)
+      goto 9999
+    end if
+
+    if (info /= psb_success_) goto 9999
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  contains
+    function inner_check(smp,sm) result(res)
+      implicit none
+      logical :: res
+      class(amg_d_base_smoother_type), intent(in), pointer :: smp 
+      class(amg_d_base_smoother_type), intent(in), target  :: sm
+
+      res = associated(smp, sm)
+    end function inner_check
+
+  end subroutine amg_d_base_onelev_check
+end submodule amg_d_base_onelev_check_impl

amgprec/impl/level/amg_d_base_onelev_cnv.f90

@@ -35,33 +35,36 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
-  
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_cnv_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_cnv
-  implicit none 
-
-  class(amg_d_onelev_type), intent(inout) :: lv
-  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
-
-  integer(psb_ipk_) :: i
-
-  info = psb_success_
   
-  if (any((/present(amold),present(vmold),present(imold)/))) then 
-    if (allocated(lv%sm)) &
-         & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
-    if (info == psb_success_ .and. allocated(lv%sm2a)) &
-         & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
-    if (info == psb_success_ .and. allocated(lv%wrk)) &
-         & call lv%wrk%cnv(info,vmold=vmold)
-    if (info == psb_success_.and. lv%ac%is_asb()) &
-         & call lv%ac%cscnv(info,mold=amold)
-    if (info == psb_success_ .and. lv%desc_ac%is_ok() &
-         & .and. present(imold)) call lv%desc_ac%cnv(imold)
-    if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
-  end if
-end subroutine amg_d_base_onelev_cnv
+contains
+  module subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
+
+    implicit none 
+
+    class(amg_d_onelev_type), intent(inout) :: lv
+    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
+
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+
+    if (any((/present(amold),present(vmold),present(imold)/))) then 
+      if (allocated(lv%sm)) &
+           & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
+      if (info == psb_success_ .and. allocated(lv%sm2a)) &
+           & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
+      if (info == psb_success_ .and. allocated(lv%wrk)) &
+           & call lv%wrk%cnv(info,vmold=vmold)
+      if (info == psb_success_.and. lv%ac%is_asb()) &
+           & call lv%ac%cscnv(info,mold=amold)
+      if (info == psb_success_ .and. lv%desc_ac%is_ok() &
+           & .and. present(imold)) call lv%desc_ac%cnv(imold)
+      if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
+    end if
+  end subroutine amg_d_base_onelev_cnv
+end submodule amg_d_base_onelev_cnv_impl

amgprec/impl/level/amg_d_base_onelev_csetc.F90

@@ -35,312 +35,309 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !
 !
-subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
-
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_csetc_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_csetc
-  use amg_d_base_aggregator_mod
-  use amg_d_dec_aggregator_mod
-  use amg_d_symdec_aggregator_mod
-  use amg_d_parmatch_aggregator_mod
-  use amg_d_poly_smoother
-  use amg_d_jac_smoother
-  use amg_d_as_smoother
-  use amg_d_richards_smoother
-  use amg_d_diag_solver
-  use amg_d_l1_diag_solver
-  use amg_d_jac_solver
-  use amg_d_ilu_solver
-  use amg_d_id_solver
-  use amg_d_gs_solver
-  use amg_d_ainv_solver
-  use amg_d_invk_solver
-  use amg_d_invt_solver
+  
+contains
+  module subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
+
+    use psb_base_mod
+    use amg_d_base_aggregator_mod
+    use amg_d_dec_aggregator_mod
+    use amg_d_symdec_aggregator_mod
+    use amg_d_parmatch_aggregator_mod
+    use amg_d_poly_smoother
+    use amg_d_jac_smoother
+    use amg_d_as_smoother
+    use amg_d_diag_solver
+    use amg_d_l1_diag_solver
+    use amg_d_jac_solver
+    use amg_d_ilu_solver
+    use amg_d_id_solver
+    use amg_d_gs_solver
+    use amg_d_ainv_solver
+    use amg_d_invk_solver
+    use amg_d_invt_solver
 #if defined(AMG_HAVE_UMF)
-  use amg_d_umf_solver
+    use amg_d_umf_solver
 #endif
 #if defined(AMG_HAVE_SLUDIST)
-  use amg_d_sludist_solver
+    use amg_d_sludist_solver
 #endif
 #if defined(AMG_HAVE_SLU)
-  use amg_d_slu_solver
+    use amg_d_slu_solver
 #endif
 #if defined(AMG_HAVE_MUMPS)
-  use amg_d_mumps_solver
+    use amg_d_mumps_solver
 #endif
 
-  Implicit None
+    Implicit None
 
-  ! Arguments
-  class(amg_d_onelev_type), intent(inout) :: lv
-  character(len=*), intent(in)              :: what
-  character(len=*), intent(in)              :: val
-  integer(psb_ipk_), intent(out)            :: info
-  character(len=*), optional, intent(in)    :: pos
-  integer(psb_ipk_), intent(in), optional   :: idx
-  ! Local
-  integer(psb_ipk_)  :: ipos_, err_act
-  character(len=20) :: name='d_base_onelev_csetc'
-  integer(psb_ipk_) :: ival
-  type(amg_d_base_smoother_type)   :: amg_d_base_smoother_mold
-  type(amg_d_jac_smoother_type)    ::  amg_d_jac_smoother_mold
-  type(amg_d_l1_jac_smoother_type) ::  amg_d_l1_jac_smoother_mold
-  type(amg_d_as_smoother_type)     ::  amg_d_as_smoother_mold
-  type(amg_d_diag_solver_type)     ::  amg_d_diag_solver_mold
-  type(amg_d_l1_diag_solver_type)  ::  amg_d_l1_diag_solver_mold
-  type(amg_d_jac_solver_type)      ::  amg_d_jac_solver_mold
-  type(amg_d_l1_jac_solver_type)   ::  amg_d_l1_jac_solver_mold
-  type(amg_d_ilu_solver_type)      ::  amg_d_ilu_solver_mold
-  type(amg_d_id_solver_type)       ::  amg_d_id_solver_mold
-  type(amg_d_gs_solver_type)       ::  amg_d_gs_solver_mold
-  type(amg_d_bwgs_solver_type)     ::  amg_d_bwgs_solver_mold
-  type(amg_d_ainv_solver_type)     ::  amg_d_ainv_solver_mold
-  type(amg_d_invk_solver_type)     ::  amg_d_invk_solver_mold
-  type(amg_d_invt_solver_type)     ::  amg_d_invt_solver_mold
-  type(amg_d_poly_smoother_type)   ::  amg_d_poly_smoother_mold
-  type(amg_d_richards_smoother_type) :: amg_d_richards_smoother_mold
+    ! Arguments
+    class(amg_d_onelev_type), intent(inout) :: lv
+    character(len=*), intent(in)              :: what
+    character(len=*), intent(in)              :: val
+    integer(psb_ipk_), intent(out)            :: info
+    character(len=*), optional, intent(in)    :: pos
+    integer(psb_ipk_), intent(in), optional   :: idx
+    ! Local
+    integer(psb_ipk_)  :: ipos_, err_act
+    character(len=20) :: name='d_base_onelev_csetc'
+    integer(psb_ipk_) :: ival
+    type(amg_d_base_smoother_type)   :: amg_d_base_smoother_mold
+    type(amg_d_jac_smoother_type)    ::  amg_d_jac_smoother_mold
+    type(amg_d_l1_jac_smoother_type) ::  amg_d_l1_jac_smoother_mold
+    type(amg_d_as_smoother_type)     ::  amg_d_as_smoother_mold
+    type(amg_d_diag_solver_type)     ::  amg_d_diag_solver_mold
+    type(amg_d_l1_diag_solver_type)  ::  amg_d_l1_diag_solver_mold
+    type(amg_d_jac_solver_type)      ::  amg_d_jac_solver_mold
+    type(amg_d_l1_jac_solver_type)   ::  amg_d_l1_jac_solver_mold
+    type(amg_d_ilu_solver_type)      ::  amg_d_ilu_solver_mold
+    type(amg_d_id_solver_type)       ::  amg_d_id_solver_mold
+    type(amg_d_gs_solver_type)       ::  amg_d_gs_solver_mold
+    type(amg_d_bwgs_solver_type)     ::  amg_d_bwgs_solver_mold
+    type(amg_d_ainv_solver_type)     ::  amg_d_ainv_solver_mold
+    type(amg_d_invk_solver_type)     ::  amg_d_invk_solver_mold
+    type(amg_d_invt_solver_type)     ::  amg_d_invt_solver_mold
+    type(amg_d_poly_smoother_type)   ::  amg_d_poly_smoother_mold
 #if defined(AMG_HAVE_UMF)
-  type(amg_d_umf_solver_type)     ::  amg_d_umf_solver_mold
+    type(amg_d_umf_solver_type)     ::  amg_d_umf_solver_mold
 #endif
 #if defined(AMG_HAVE_SLUDIST)
-  type(amg_d_sludist_solver_type) ::  amg_d_sludist_solver_mold
+    type(amg_d_sludist_solver_type) ::  amg_d_sludist_solver_mold
 #endif
 #if defined(AMG_HAVE_SLU)
-  type(amg_d_slu_solver_type)   ::  amg_d_slu_solver_mold
+    type(amg_d_slu_solver_type)   ::  amg_d_slu_solver_mold
 #endif
 #if defined(AMG_HAVE_MUMPS)
-  type(amg_d_mumps_solver_type) ::  amg_d_mumps_solver_mold
+    type(amg_d_mumps_solver_type) ::  amg_d_mumps_solver_mold
 #endif
 
 
-  call psb_erractionsave(err_act)
+    call psb_erractionsave(err_act)
 
-  info = psb_success_
+    info = psb_success_
 
-  ival = lv%stringval(val)
+    ival = lv%stringval(val)
 
 
-  if (present(pos)) then
-    select case(psb_toupper(trim(pos)))
-    case('PRE')
-      ipos_ = amg_smooth_pre_
-    case('POST')
-      ipos_ = amg_smooth_post_
-    case default
+    if (present(pos)) then
+      select case(psb_toupper(trim(pos)))
+      case('PRE')
+        ipos_ = amg_smooth_pre_
+      case('POST')
+        ipos_ = amg_smooth_post_
+      case default
+        ipos_ = amg_smooth_both_
+      end select
+    else
       ipos_ = amg_smooth_both_
-    end select
-  else
-    ipos_ = amg_smooth_both_
-  end if
-
-  select case (psb_toupper(trim(what)))
-  case ('SMOOTHER_TYPE')
-    select case (psb_toupper(trim(val)))
-    case ('NOPREC','NONE')
-      call lv%set(amg_d_base_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos)
-
-    case ('JAC','JACOBI')
-      call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos)
-
-    case ('L1-JACOBI')
-      call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
-
-    case ('BJAC')
-      call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-
-    case ('L1-BJAC')
-      call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-
-    case ('AS')
-      call lv%set(amg_d_as_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-
-    case ('POLY')
-      call lv%set(amg_d_poly_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
-
-    case ('RICHARDS','RICHARDSON')
-      call lv%set(amg_d_richards_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-
-    case ('GS','FWGS')
-      call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
-      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
-    case ('BWGS')
-      call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre')
-      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
-    case ('FBGS')
-      call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
-      call lv%set(amg_d_jac_smoother_mold,info,pos='post')
-      if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
-    case ('L1-GS','L1-FWGS')
-      call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
-      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
-    case ('L1-BWGS')
-      call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre')
-      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
-    case ('L1-FBGS')
-      call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
-      call lv%set(amg_d_l1_jac_smoother_mold,info,pos='post')
-      if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
-
-    case default
-      !
-      ! Do nothing and hope for the best :)
-      !
-    end select
-    if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm)) call lv%sm%default()
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm2a)) call lv%sm2a%default()
     end if
 
+    select case (psb_toupper(trim(what)))
+    case ('SMOOTHER_TYPE')
+      select case (psb_toupper(trim(val)))
+      case ('NOPREC','NONE')
+        call lv%set(amg_d_base_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos)
 
-  case('SUB_SOLVE')
-    select case (psb_toupper(trim(val)))
-    case ('NONE','NOPREC','FACT_NONE')
-      call lv%set(amg_d_id_solver_mold,info,pos=pos)
+      case ('JAC','JACOBI')
+        call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos)
 
-    case ('DIAG','JACOBI')
-      call lv%set(amg_d_diag_solver_mold,info,pos=pos)
+      case ('L1-JACOBI')
+        call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
 
-    case ('L1-DIAG','L1-JACOBI')
-      call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
+      case ('BJAC')
+        call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
 
-    case ('GS','FGS','FWGS')
-      call lv%set(amg_d_gs_solver_mold,info,pos=pos)
+      case ('L1-BJAC')
+        call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
 
-    case ('BGS','BWGS')
-      call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
+      case ('AS')
+        call lv%set(amg_d_as_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
 
-    case ('AINV')
-      call lv%set(amg_d_ainv_solver_mold,info,pos=pos)
-    case ('INVK')
-      call lv%set(amg_d_invk_solver_mold,info,pos=pos)
-    case ('INVT')
-      call lv%set(amg_d_invt_solver_mold,info,pos=pos)
-    case ('ILU','ILUT','MILU')
-      call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-      if (info == 0) then
-        if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
-          call lv%sm%sv%set('SUB_SOLVE',val,info)
-        end if
-        if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
-          if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
-        end if
+      case ('POLY')
+        call lv%set(amg_d_poly_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
+      case ('GS','FWGS')
+        call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
+        if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+      case ('BWGS')
+        call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre')
+        if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+      case ('FBGS')
+        call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
+        call lv%set(amg_d_jac_smoother_mold,info,pos='post')
+        if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
+      case ('L1-GS','L1-FWGS')
+        call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
+        if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+      case ('L1-BWGS')
+        call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre')
+        if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+      case ('L1-FBGS')
+        call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
+        call lv%set(amg_d_l1_jac_smoother_mold,info,pos='post')
+        if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
+
+      case default
+        !
+        ! Do nothing and hope for the best :)
+        !
+      end select
+      if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm)) call lv%sm%default()
       end if
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm2a)) call lv%sm2a%default()
+      end if
+
+
+    case('SUB_SOLVE')
+      select case (psb_toupper(trim(val)))
+      case ('NONE','NOPREC','FACT_NONE')
+        call lv%set(amg_d_id_solver_mold,info,pos=pos)
+
+      case ('DIAG','JACOBI')
+        call lv%set(amg_d_diag_solver_mold,info,pos=pos)
+
+      case ('L1-DIAG','L1-JACOBI')
+        call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
+
+      case ('GS','FGS','FWGS')
+        call lv%set(amg_d_gs_solver_mold,info,pos=pos)
+
+      case ('BGS','BWGS')
+        call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
+
+      case ('AINV')
+        call lv%set(amg_d_ainv_solver_mold,info,pos=pos)
+      case ('INVK')
+        call lv%set(amg_d_invk_solver_mold,info,pos=pos)
+      case ('INVT')
+        call lv%set(amg_d_invt_solver_mold,info,pos=pos)
+      case ('ILU','ILUT','MILU')
+        call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
+        if (info == 0) then
+          if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
+            call lv%sm%sv%set('SUB_SOLVE',val,info)
+          end if
+          if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
+            if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
+          end if
+        end if
 #ifdef AMG_HAVE_SLU
-    case ('SLU')
-      call lv%set(amg_d_slu_solver_mold,info,pos=pos)
+      case ('SLU')
+        call lv%set(amg_d_slu_solver_mold,info,pos=pos)
 #endif
 #ifdef AMG_HAVE_MUMPS 
-    case ('MUMPS')
-      call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
+      case ('MUMPS')
+        call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
 #endif
 #ifdef AMG_HAVE_SLUDIST
-    case ('SLUDIST')
-      call lv%set(amg_d_sludist_solver_mold,info,pos=pos)
+      case ('SLUDIST')
+        call lv%set(amg_d_sludist_solver_mold,info,pos=pos)
 #endif
 #ifdef AMG_HAVE_UMF
-    case ('UMF')
-      call lv%set(amg_d_umf_solver_mold,info,pos=pos)
+      case ('UMF')
+        call lv%set(amg_d_umf_solver_mold,info,pos=pos)
 #endif
-    case default
-      !
-      ! Do nothing and hope for the best :)
-      !
-    end select
+      case default
+        !
+        ! Do nothing and hope for the best :)
+        !
+      end select
 
-  case ('ML_CYCLE')
-    lv%parms%ml_cycle      = amg_stringval(val)
+    case ('ML_CYCLE')
+      lv%parms%ml_cycle      = amg_stringval(val)
 
-  case ('PAR_AGGR_ALG')
-    ival = amg_stringval(val)
-    lv%parms%par_aggr_alg  = ival
-    if (allocated(lv%aggr)) then
-      call lv%aggr%free(info)
-      if (info == 0) deallocate(lv%aggr,stat=info)
-      if (info /= 0) then
-        info = psb_err_internal_error_
-        call psb_errpush(info,name,a_err='aggregator deallocation?')
+    case ('PAR_AGGR_ALG')
+      ival = amg_stringval(val)
+      lv%parms%par_aggr_alg  = ival
+      if (allocated(lv%aggr)) then
+        call lv%aggr%free(info)
+        if (info == 0) deallocate(lv%aggr,stat=info)
+        if (info /= 0) then
+          info = psb_err_internal_error_
+          call psb_errpush(info,name,a_err='aggregator deallocation?')
+          goto 9999
+          return
+        end if
+      end if
+
+      select case(val)
+      case('DEC','DECOUPLED')
+        allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
+      case('SYMDEC')
+        allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)
+      case('COUP','COUPLED')
+        allocate(amg_d_parmatch_aggregator_type :: lv%aggr, stat=info)
+      case default
+        info =  psb_err_internal_error_
+        call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
         goto 9999
-        return
-      end if
-    end if
+      end select
+      if (info == psb_success_) call lv%aggr%default()
+
+    case ('AGGR_ORD')
+      lv%parms%aggr_ord      = amg_stringval(val)
+
+    case ('AGGR_TYPE')
+      lv%parms%aggr_type     = amg_stringval(val)
+      if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
+
+    case ('AGGR_PROL')
+      lv%parms%aggr_prol     = amg_stringval(val)
+
+    case ('COARSE_MAT')
+      lv%parms%coarse_mat    = amg_stringval(val)
+
+    case ('AGGR_OMEGA_ALG')
+      lv%parms%aggr_omega_alg= amg_stringval(val)
+
+    case ('AGGR_EIG')
+      lv%parms%aggr_eig      = amg_stringval(val)
+
+    case ('AGGR_FILTER')
+      lv%parms%aggr_filter   = amg_stringval(val)
+
+    case ('COARSE_SOLVE')
+      lv%parms%coarse_solve    = amg_stringval(val)
+
+    case default
+      if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm)) then
+          call lv%sm%set(what,val,info,idx=idx)
+        end if
+      end if
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
+        if (allocated(lv%sm2a)) then
+          call lv%sm2a%set(what,val,info,idx=idx)
+        end if
+      end if
+      if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
 
-    select case(val)
-    case('DEC','DECOUPLED')
-      allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
-    case('SYMDEC')
-      allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)
-    case('COUP','COUPLED')
-      allocate(amg_d_parmatch_aggregator_type :: lv%aggr, stat=info)
-  case default
-      info =  psb_err_internal_error_
-      call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
-      goto 9999
     end select
-    if (info == psb_success_) call lv%aggr%default()
-
-  case ('AGGR_ORD')
-    lv%parms%aggr_ord      = amg_stringval(val)
-
-  case ('AGGR_TYPE')
-    lv%parms%aggr_type     = amg_stringval(val)
-    if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
-
-  case ('AGGR_PROL')
-    lv%parms%aggr_prol     = amg_stringval(val)
-
-  case ('COARSE_MAT')
-    lv%parms%coarse_mat    = amg_stringval(val)
-
-  case ('AGGR_OMEGA_ALG')
-    lv%parms%aggr_omega_alg= amg_stringval(val)
-
-  case ('AGGR_EIG')
-    lv%parms%aggr_eig      = amg_stringval(val)
-
-  case ('AGGR_FILTER')
-    lv%parms%aggr_filter   = amg_stringval(val)
-
-  case ('COARSE_SOLVE')
-    lv%parms%coarse_solve    = amg_stringval(val)
-
-  case default
-    if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm)) then
-        call lv%sm%set(what,val,info,idx=idx)
-      end if
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
-      if (allocated(lv%sm2a)) then
-        call lv%sm2a%set(what,val,info,idx=idx)
-      end if
-    end if
-    if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
-
-  end select
 
 
-  if (info /= psb_success_) goto 9999
+    if (info /= psb_success_) goto 9999
 
-  call psb_erractionrestore(err_act)
-  return
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_d_base_onelev_csetc
+  end subroutine amg_d_base_onelev_csetc
+end submodule amg_d_base_onelev_csetc_impl

amgprec/impl/level/amg_d_base_onelev_cseti.F90

@@ -35,261 +35,259 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !
 !
-subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
-
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_cseti_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_cseti
-  use amg_d_base_aggregator_mod
-  use amg_d_dec_aggregator_mod
-  use amg_d_symdec_aggregator_mod
-  use amg_d_parmatch_aggregator_mod
-  use amg_d_jac_smoother
-  use amg_d_as_smoother
-  use amg_d_richards_smoother
-  use amg_d_diag_solver
-  use amg_d_l1_diag_solver
-  use amg_d_ilu_solver
-  use amg_d_id_solver
-  use amg_d_gs_solver
+  
+contains
+  module subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
+
+    use psb_base_mod
+    use amg_d_base_aggregator_mod
+    use amg_d_dec_aggregator_mod
+    use amg_d_symdec_aggregator_mod
+    use amg_d_parmatch_aggregator_mod
+    use amg_d_jac_smoother
+    use amg_d_as_smoother
+    use amg_d_diag_solver
+    use amg_d_l1_diag_solver
+    use amg_d_ilu_solver
+    use amg_d_id_solver
+    use amg_d_gs_solver
 #if defined(AMG_HAVE_UMF)
-  use amg_d_umf_solver
+    use amg_d_umf_solver
 #endif
 #if defined(AMG_HAVE_SLUDIST)
-  use amg_d_sludist_solver
+    use amg_d_sludist_solver
 #endif
 #if defined(AMG_HAVE_SLU)
-  use amg_d_slu_solver
+    use amg_d_slu_solver
 #endif
 #if defined(AMG_HAVE_MUMPS)
-  use amg_d_mumps_solver
+    use amg_d_mumps_solver
 #endif
 
-  Implicit None
+    Implicit None
 
-  ! Arguments
-  class(amg_d_onelev_type), intent(inout) :: lv
-  character(len=*), intent(in)              :: what
-  integer(psb_ipk_), intent(in)             :: val
-  integer(psb_ipk_), intent(out)            :: info
-  character(len=*), optional, intent(in)    :: pos
-  integer(psb_ipk_), intent(in), optional   :: idx
-  ! Local
-  integer(psb_ipk_)  :: ipos_, err_act
-  character(len=20) :: name='d_base_onelev_cseti'
-  type(amg_d_base_smoother_type)   :: amg_d_base_smoother_mold
-  type(amg_d_jac_smoother_type)    ::  amg_d_jac_smoother_mold
-  type(amg_d_l1_jac_smoother_type) ::  amg_d_l1_jac_smoother_mold
-  type(amg_d_as_smoother_type)     ::  amg_d_as_smoother_mold
-  type(amg_d_richards_smoother_type) :: amg_d_richards_smoother_mold
-  type(amg_d_diag_solver_type)     ::  amg_d_diag_solver_mold
-  type(amg_d_l1_diag_solver_type)  ::  amg_d_l1_diag_solver_mold
-  type(amg_d_ilu_solver_type)      ::  amg_d_ilu_solver_mold
-  type(amg_d_id_solver_type)       ::  amg_d_id_solver_mold
-  type(amg_d_gs_solver_type)       ::  amg_d_gs_solver_mold
-  type(amg_d_bwgs_solver_type)     ::  amg_d_bwgs_solver_mold
+    ! Arguments
+    class(amg_d_onelev_type), intent(inout) :: lv
+    character(len=*), intent(in)              :: what
+    integer(psb_ipk_), intent(in)             :: val
+    integer(psb_ipk_), intent(out)            :: info
+    character(len=*), optional, intent(in)    :: pos
+    integer(psb_ipk_), intent(in), optional   :: idx
+    ! Local
+    integer(psb_ipk_)  :: ipos_, err_act
+    character(len=20) :: name='d_base_onelev_cseti'
+    type(amg_d_base_smoother_type)   :: amg_d_base_smoother_mold
+    type(amg_d_jac_smoother_type)    ::  amg_d_jac_smoother_mold
+    type(amg_d_l1_jac_smoother_type) ::  amg_d_l1_jac_smoother_mold
+    type(amg_d_as_smoother_type)     ::  amg_d_as_smoother_mold
+    type(amg_d_diag_solver_type)     ::  amg_d_diag_solver_mold
+    type(amg_d_l1_diag_solver_type)  ::  amg_d_l1_diag_solver_mold
+    type(amg_d_ilu_solver_type)      ::  amg_d_ilu_solver_mold
+    type(amg_d_id_solver_type)       ::  amg_d_id_solver_mold
+    type(amg_d_gs_solver_type)       ::  amg_d_gs_solver_mold
+    type(amg_d_bwgs_solver_type)     ::  amg_d_bwgs_solver_mold
 #if defined(AMG_HAVE_UMF)
-  type(amg_d_umf_solver_type)     ::  amg_d_umf_solver_mold
+    type(amg_d_umf_solver_type)     ::  amg_d_umf_solver_mold
 #endif
 #if defined(AMG_HAVE_SLUDIST)
-  type(amg_d_sludist_solver_type) ::  amg_d_sludist_solver_mold
+    type(amg_d_sludist_solver_type) ::  amg_d_sludist_solver_mold
 #endif
 #if defined(AMG_HAVE_SLU)
-  type(amg_d_slu_solver_type)   ::  amg_d_slu_solver_mold
+    type(amg_d_slu_solver_type)   ::  amg_d_slu_solver_mold
 #endif
 #if defined(AMG_HAVE_MUMPS)
-  type(amg_d_mumps_solver_type) ::  amg_d_mumps_solver_mold
+    type(amg_d_mumps_solver_type) ::  amg_d_mumps_solver_mold
 #endif
 
-  call psb_erractionsave(err_act)
-  info = psb_success_
+    call psb_erractionsave(err_act)
+    info = psb_success_
 
-  if (present(pos)) then
-    select case(psb_toupper(trim(pos)))
-    case('PRE')
-      ipos_ = amg_smooth_pre_
-    case('POST')
-      ipos_ = amg_smooth_post_
-    case default
+    if (present(pos)) then
+      select case(psb_toupper(trim(pos)))
+      case('PRE')
+        ipos_ = amg_smooth_pre_
+      case('POST')
+        ipos_ = amg_smooth_post_
+      case default
+        ipos_ = amg_smooth_both_
+      end select
+    else
       ipos_ = amg_smooth_both_
-    end select
-  else
-    ipos_ = amg_smooth_both_
-  end if
-
-  select case (psb_toupper(what))
-  case ('SMOOTHER_TYPE')
-    select case (val)
-    case (amg_noprec_)
-      call lv%set(amg_d_base_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos)
-
-    case (amg_jac_)
-      call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos)
-
-    case (amg_l1_jac_)
-      call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
-
-    case (amg_bjac_)
-      call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-
-    case (amg_l1_bjac_)
-      call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-
-    case (amg_as_)
-      call lv%set(amg_d_as_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-
-    case (amg_richardson_)
-      call lv%set(amg_d_richards_smoother_mold,info,pos=pos)
-      if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-
-    case (amg_fbgs_)
-      call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
-      if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
-      call lv%set(amg_d_jac_smoother_mold,info,pos='post')
-      if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
-
-    case default
-      !
-      ! Do nothing and hope for the best :)
-      !
-    end select
-    if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm)) call lv%sm%default()
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm2a)) call lv%sm2a%default()
     end if
 
+    select case (psb_toupper(what))
+    case ('SMOOTHER_TYPE')
+      select case (val)
+      case (amg_noprec_)
+        call lv%set(amg_d_base_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos)
 
-  case('SUB_SOLVE')
-    select case (val)
-    case (amg_f_none_)
-      call lv%set(amg_d_id_solver_mold,info,pos=pos)
+      case (amg_jac_)
+        call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos)
 
-    case (amg_diag_scale_)
-      call lv%set(amg_d_diag_solver_mold,info,pos=pos)
+      case (amg_l1_jac_)
+        call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
 
-    case (amg_l1_diag_scale_)
-      call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
+      case (amg_bjac_)
+        call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
 
-    case (amg_gs_)
-      call lv%set(amg_d_gs_solver_mold,info,pos=pos)
+      case (amg_l1_bjac_)
+        call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
 
-    case (amg_bwgs_)
-      call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
+      case (amg_as_)
+        call lv%set(amg_d_as_smoother_mold,info,pos=pos)
+        if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
 
-    case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
-      call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
-      if (info == 0) then
-        if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
-          call lv%sm%sv%set('SUB_SOLVE',val,info)
-        end if
-        if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
-          if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
-        end if
+      case (amg_fbgs_)
+        call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
+        if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
+        call lv%set(amg_d_jac_smoother_mold,info,pos='post')
+        if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
+
+      case default
+        !
+        ! Do nothing and hope for the best :)
+        !
+      end select
+      if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm)) call lv%sm%default()
       end if
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm2a)) call lv%sm2a%default()
+      end if
+
+
+    case('SUB_SOLVE')
+      select case (val)
+      case (amg_f_none_)
+        call lv%set(amg_d_id_solver_mold,info,pos=pos)
+
+      case (amg_diag_scale_)
+        call lv%set(amg_d_diag_solver_mold,info,pos=pos)
+
+      case (amg_l1_diag_scale_)
+        call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
+
+      case (amg_gs_)
+        call lv%set(amg_d_gs_solver_mold,info,pos=pos)
+
+      case (amg_bwgs_)
+        call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
+
+      case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
+        call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
+        if (info == 0) then
+          if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
+            call lv%sm%sv%set('SUB_SOLVE',val,info)
+          end if
+          if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
+            if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
+          end if
+        end if
 #ifdef AMG_HAVE_SLU
-    case (amg_slu_)
-      call lv%set(amg_d_slu_solver_mold,info,pos=pos)
+      case (amg_slu_)
+        call lv%set(amg_d_slu_solver_mold,info,pos=pos)
 #endif
 #ifdef AMG_HAVE_MUMPS
-    case (amg_mumps_)
-      call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
+      case (amg_mumps_)
+        call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
 #endif
 #ifdef AMG_HAVE_SLUDIST
-    case (amg_sludist_)
-      call lv%set(amg_d_sludist_solver_mold,info,pos=pos)
+      case (amg_sludist_)
+        call lv%set(amg_d_sludist_solver_mold,info,pos=pos)
 #endif
 #ifdef AMG_HAVE_UMF
-    case (amg_umf_)
-      call lv%set(amg_d_umf_solver_mold,info,pos=pos)
+      case (amg_umf_)
+        call lv%set(amg_d_umf_solver_mold,info,pos=pos)
 #endif
+      case default
+        !
+        ! Do nothing and hope for the best :)
+        !
+      end select
+
+
+    case ('SMOOTHER_SWEEPS')
+      if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
+           &  lv%parms%sweeps_pre  = val
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
+           &  lv%parms%sweeps_post = val
+
+    case ('ML_CYCLE')
+      lv%parms%ml_cycle      = val
+
+    case ('PAR_AGGR_ALG')
+      lv%parms%par_aggr_alg  = val
+      if (allocated(lv%aggr)) then
+        call lv%aggr%free(info)
+        if (info == 0) deallocate(lv%aggr,stat=info)
+        if (info /= 0) then
+          info = psb_err_internal_error_
+          return
+        end if
+      end if
+
+      select case(val)
+      case(amg_dec_aggr_)
+        allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
+      case(amg_sym_dec_aggr_)
+        allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)
+      case default
+        info =  psb_err_internal_error_
+      end select
+      if (info == psb_success_) call lv%aggr%default()
+
+    case ('AGGR_ORD')
+      lv%parms%aggr_ord      = val
+
+    case ('AGGR_TYPE')
+      lv%parms%aggr_type     = val
+      if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
+
+    case ('AGGR_PROL')
+      lv%parms%aggr_prol     = val
+
+    case ('COARSE_MAT')
+      lv%parms%coarse_mat    = val
+
+    case ('AGGR_OMEGA_ALG')
+      lv%parms%aggr_omega_alg= val
+
+    case ('AGGR_EIG')
+      lv%parms%aggr_eig      = val
+
+    case ('AGGR_FILTER')
+      lv%parms%aggr_filter   = val
+
+    case ('COARSE_SOLVE')
+      lv%parms%coarse_solve    = val
+
     case default
-      !
-      ! Do nothing and hope for the best :)
-      !
+      if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
+        if (allocated(lv%sm)) then
+          call lv%sm%set(what,val,info,idx=idx)
+        end if
+      end if
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
+        if (allocated(lv%sm2a)) then
+          call lv%sm2a%set(what,val,info,idx=idx)
+        end if
+      end if
+      if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
+
     end select
-
-
-  case ('SMOOTHER_SWEEPS')
-    if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
-         &  lv%parms%sweeps_pre  = val
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
-         &  lv%parms%sweeps_post = val
-
-  case ('ML_CYCLE')
-    lv%parms%ml_cycle      = val
-
-  case ('PAR_AGGR_ALG')
-    lv%parms%par_aggr_alg  = val
-    if (allocated(lv%aggr)) then
-      call lv%aggr%free(info)
-      if (info == 0) deallocate(lv%aggr,stat=info)
-      if (info /= 0) then
-        info = psb_err_internal_error_
-        return
-      end if
-    end if
-
-    select case(val)
-    case(amg_dec_aggr_)
-      allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
-    case(amg_sym_dec_aggr_)
-      allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)
-    case default
-      info =  psb_err_internal_error_
-    end select
-    if (info == psb_success_) call lv%aggr%default()
-
-  case ('AGGR_ORD')
-    lv%parms%aggr_ord      = val
-
-  case ('AGGR_TYPE')
-    lv%parms%aggr_type     = val
-    if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
-
-  case ('AGGR_PROL')
-    lv%parms%aggr_prol     = val
-
-  case ('COARSE_MAT')
-    lv%parms%coarse_mat    = val
-
-  case ('AGGR_OMEGA_ALG')
-    lv%parms%aggr_omega_alg= val
-
-  case ('AGGR_EIG')
-    lv%parms%aggr_eig      = val
-
-  case ('AGGR_FILTER')
-    lv%parms%aggr_filter   = val
-
-  case ('COARSE_SOLVE')
-    lv%parms%coarse_solve    = val
-
-  case default
-    if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
-      if (allocated(lv%sm)) then
-        call lv%sm%set(what,val,info,idx=idx)
-      end if
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
-      if (allocated(lv%sm2a)) then
-        call lv%sm2a%set(what,val,info,idx=idx)
-      end if
-    end if
-    if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
-
-  end select
-  if (info /= psb_success_) goto 9999
-  call psb_erractionrestore(err_act)
-  return
+    if (info /= psb_success_) goto 9999
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_d_base_onelev_cseti
+  end subroutine amg_d_base_onelev_cseti
+end submodule amg_d_base_onelev_cseti_impl

amgprec/impl/level/amg_d_base_onelev_csetr.f90

@@ -35,71 +35,73 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
-  
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_csetr_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_csetr
+  
+contains
+  module subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
 
-  Implicit None
+    Implicit None
 
-  ! Arguments
-  class(amg_d_onelev_type), intent(inout) :: lv 
-  character(len=*), intent(in)              :: what 
-  real(psb_dpk_), intent(in)                 :: val
-  integer(psb_ipk_), intent(out)            :: info
-  character(len=*), optional, intent(in)    :: pos
-  integer(psb_ipk_), intent(in), optional   :: idx
-  ! Local 
-  integer(psb_ipk_)  :: ipos_, err_act
-  character(len=20) :: name='d_base_onelev_csetr'
+    ! Arguments
+    class(amg_d_onelev_type), intent(inout) :: lv 
+    character(len=*), intent(in)              :: what 
+    real(psb_dpk_), intent(in)                 :: val
+    integer(psb_ipk_), intent(out)            :: info
+    character(len=*), optional, intent(in)    :: pos
+    integer(psb_ipk_), intent(in), optional   :: idx
+    ! Local 
+    integer(psb_ipk_)  :: ipos_, err_act
+    character(len=20) :: name='d_base_onelev_csetr'
 
-  call psb_erractionsave(err_act)
+    call psb_erractionsave(err_act)
 
 
-  info = psb_success_
+    info = psb_success_
 
-  select case (psb_toupper(what))
+    select case (psb_toupper(what))
 
-  case ('AGGR_OMEGA_VAL')
-    lv%parms%aggr_omega_val= val
+    case ('AGGR_OMEGA_VAL')
+      lv%parms%aggr_omega_val= val
 
-  case ('AGGR_THRESH')
-    lv%parms%aggr_thresh   = val
+    case ('AGGR_THRESH')
+      lv%parms%aggr_thresh   = val
 
-  case default
-    
-    if (present(pos)) then
-      select case(psb_toupper(trim(pos)))
-      case('PRE')
-        ipos_ = amg_smooth_pre_
-      case('POST')
-        ipos_ = amg_smooth_post_
-      case default
+    case default
+
+      if (present(pos)) then
+        select case(psb_toupper(trim(pos)))
+        case('PRE')
+          ipos_ = amg_smooth_pre_
+        case('POST')
+          ipos_ = amg_smooth_post_
+        case default
+          ipos_ = amg_smooth_both_
+        end select
+      else
         ipos_ = amg_smooth_both_
-      end select
-    else
-      ipos_ = amg_smooth_both_
-    end if
-
-    if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then 
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info,idx=idx)
       end if
-    end if
-    if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then 
-      if (allocated(lv%sm2a)) then 
-        call lv%sm2a%set(what,val,info,idx=idx)
+
+      if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then 
+        if (allocated(lv%sm)) then 
+          call lv%sm%set(what,val,info,idx=idx)
+        end if
       end if
-    end if
-    if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
+      if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then 
+        if (allocated(lv%sm2a)) then 
+          call lv%sm2a%set(what,val,info,idx=idx)
+        end if
+      end if
+      if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
 
-  end select
+    end select
 
-  if (info /= psb_success_) goto 9999
-  call psb_erractionrestore(err_act)
-  return
+    if (info /= psb_success_) goto 9999
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_d_base_onelev_csetr
+  end subroutine amg_d_base_onelev_csetr
+end submodule amg_d_base_onelev_csetr_impl

amgprec/impl/level/amg_d_base_onelev_descr.f90

@@ -42,108 +42,116 @@
 !         0: normal
 !        >1: increased details 
 !
-subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
-  
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_descr_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_descr
-  Implicit None
-  ! Arguments
-  class(amg_d_onelev_type), intent(in)    :: lv
-  integer(psb_ipk_), intent(in)           :: il,nl,ilmin
-  integer(psb_ipk_), intent(out)          :: info
-  integer(psb_ipk_), intent(in), optional :: iout
-  integer(psb_ipk_), intent(in), optional :: verbosity
-  character(len=*), intent(in), optional  :: prefix
-
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  character(len=20), parameter :: name='amg_d_base_onelev_descr'
-  integer(psb_ipk_)  :: iout_, verbosity_
-  logical      :: coarse
-  character(1024)    :: prefix_
-
-
-  call psb_erractionsave(err_act)
-
-
-  coarse = (il==nl)
-
-  if (present(iout)) then 
-    iout_ = iout
-  else 
-    iout_ = psb_out_unit
-  end if
   
-  if (present(verbosity)) then
-    verbosity_ = verbosity
-  else
-    verbosity_ = 0
-  end if
-  if (verbosity_ < 0) goto 9998
+contains
+  module subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
+    Implicit None
+    ! Arguments
+    class(amg_d_onelev_type), intent(in)    :: lv
+    integer(psb_ipk_), intent(in)           :: il,nl,ilmin
+    integer(psb_ipk_), intent(out)          :: info
+    integer(psb_ipk_), intent(in), optional :: iout
+    integer(psb_ipk_), intent(in), optional :: verbosity
+    character(len=*), intent(in), optional  :: prefix
+
+
+    ! Local variables
+    integer(psb_ipk_)  :: err_act
+    character(len=20), parameter :: name='amg_d_base_onelev_descr'
+    integer(psb_ipk_)  :: iout_, verbosity_
+    logical      :: coarse
+    character(1024)    :: prefix_
+    type(psb_ctxt_type) :: pctxt
+    integer(psb_ipk_)   :: pme, pnp
+
+
+    call psb_erractionsave(err_act)
+
+
+    coarse = (il==nl)
+
+    if (present(iout)) then 
+      iout_ = iout
+    else 
+      iout_ = psb_out_unit
+    end if
+
+    if (present(verbosity)) then
+      verbosity_ = verbosity
+    else
+      verbosity_ = 0
+    end if
+    if (verbosity_ < 0) goto 9998
     if (present(prefix)) then
       prefix_ = prefix
     else
       prefix_ = ""
     end if
 
-  write(iout_,*) trim(prefix_)
-  if (il == ilmin) then 
-    call lv%parms%mlcycledsc(iout_,info)
-  end if
-  if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then 
-    if (allocated(lv%aggr)) then
-      call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
-    else
-      write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
-      info = psb_err_internal_error_
-      call psb_errpush(info,name)
-      goto 9999
-    end if
+    pctxt = lv%desc_ac%get_ctxt()
+    call psb_info(pctxt,pme,pnp) 
     write(iout_,*) trim(prefix_)
-  end if
-  
-  if (il > 1) then 
-
-    if (coarse)  then 
-      write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
-    else
-      write(iout_,*) trim(prefix_), ' Level ',il
+    write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
+    write(iout_,*) trim(prefix_)
+    if (il == ilmin) then 
+      call lv%parms%mlcycledsc(iout_,info)
     end if
-
-    call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
-
-    if (nl > 1) then 
-      if (allocated(lv%linmap%naggr)) then
-        write(iout_,*) trim(prefix_), '  Coarse Matrix: Global size: ', &
-             &  lv%linmap%nagtot
-        write(iout_,*) trim(prefix_), '                    Nonzeros: ',lv%ac_nz_tot
-        if (verbosity_>0) then
-          write(iout_,*) trim(prefix_), '          Local matrix sizes: ', &
-               &  lv%linmap%naggr(:)
-        else 
-          write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
-               & '     Local  matrix sizes: min:', &
-               & lv%linmap%nagmin,'         max:', lv%linmap%nagmax
-          write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
-               & '                          avg:', &
-               & lv%linmap%nagavg
-        end if
-        write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
-             & '          Aggregation   ratio: ', &
-             &  lv%szratio
+    if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then 
+      if (allocated(lv%aggr)) then
+        call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
+      else
+        write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
+        info = psb_err_internal_error_
+        call psb_errpush(info,name)
+        goto 9999
       end if
+      write(iout_,*) trim(prefix_)
     end if
 
-    if (coarse.and.allocated(lv%sm)) &
-         & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
-  end if
+    if (il > 1) then 
+
+      if (coarse)  then 
+        write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
+      else
+        write(iout_,*) trim(prefix_), ' Level ',il
+      end if
+
+      call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
+
+      if (nl > 1) then 
+        if (allocated(lv%linmap%naggr)) then
+          write(iout_,*) trim(prefix_), '  Coarse Matrix: Global size: ', &
+               &  lv%linmap%nagtot
+          write(iout_,*) trim(prefix_), '                    Nonzeros: ',lv%ac_nz_tot
+          if (verbosity_>0) then
+            write(iout_,*) trim(prefix_), '          Local matrix sizes: ', &
+                 &  lv%linmap%naggr(:)
+          else 
+            write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
+                 & '     Local  matrix sizes: min:', &
+                 & lv%linmap%nagmin,'         max:', lv%linmap%nagmax
+            write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
+                 & '                          avg:', &
+                 & lv%linmap%nagavg
+          end if
+          write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
+               & '          Aggregation   ratio: ', &
+               &  lv%szratio
+        end if
+      end if
+
+      if (coarse.and.allocated(lv%sm)) &
+           & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
+    end if
 
 9998 continue
-  call psb_erractionrestore(err_act)
-  return
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_d_base_onelev_descr
+  end subroutine amg_d_base_onelev_descr
+end submodule amg_d_base_onelev_descr_impl

amgprec/impl/level/amg_d_base_onelev_dump.f90

@@ -35,135 +35,137 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
-     & smoother,solver,tprol,global_num)
-
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_dump_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_dump
-  implicit none 
-  class(amg_d_onelev_type), intent(in) :: lv
-  integer(psb_ipk_), intent(in)          :: level
-  integer(psb_ipk_), intent(out)         :: info
-  character(len=*), intent(in), optional :: prefix, head
-  logical, optional, intent(in)    :: ac, rp, smoother, solver, tprol, global_num
-  ! Local variables
-  integer(psb_ipk_)   :: i, j, il1, iln, lname, lev, ni
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: iam, np
-  character(len=80)   :: prefix_, frmt
-  character(len=1024) :: fname 
-  logical :: ac_, rp_, tprol_, global_num_
-  integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
-
-  info = 0
-
-  if (present(prefix)) then 
-    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-  else
-    prefix_ = "dump_lev_d"
-  end if
-
-  if (associated(lv%base_desc)) then 
-    ctxt = lv%base_desc%get_context()
-    call psb_info(ctxt,iam,np)
-  else 
-    iam     = -1
-    np      = -1
-  end if
-  if (present(ac)) then 
-    ac_ = ac
-  else
-    ac_ = .false. 
-  end if
-  if (present(rp)) then 
-    rp_ = rp
-  else
-    rp_ = .false. 
-  end if
-  if (present(tprol)) then 
-    tprol_ = tprol
-  else
-    tprol_ = .false. 
-  end if
-  if (present(global_num)) then 
-    global_num_ = global_num
-  else
-    global_num_ = .false. 
-  end if
-  lname = len_trim(prefix_)
-  fname = trim(prefix_)
-
-  if (np > 0) then 
-    ni  = floor(log10(1.0*np)) + 1
-    write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
-    write(fname(lname+1:lname+ni+2),frmt) '_p',iam
-    lname = lname + ni + 2
-  end if
-
-  if (global_num_) then
-    if (level == 1) then
-      if (ac_) then
-        ivr = lv%base_desc%get_global_indices(owned=.false.)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        call lv%base_a%print(fname,head=head,iv=ivr)
-      end if
-    else if (level >= 2) then 
-      if (ac_) then
-        ivr = lv%desc_ac%get_global_indices(owned=.false.)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        call lv%ac%print(fname,head=head,iv=ivr)
-      end if
-      if (rp_) then 
-        ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
-        ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
-        call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
-        call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
-      end if
-      if (tprol_) then
-        ! Tentative prolongator is stored with column indices already
-        ! in global numbering, so only IVR is needed. 
-        ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
-        !
-        call lv%tprol%print(fname,head=head,ivr=ivr)
-      end if
-    end if
-  else
-    if (level == 1) then
-      if (ac_) then
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        call lv%base_a%print(fname,head=head)
-      end if
-    else  if (level >= 2) then 
-      if (ac_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        call lv%ac%print(fname,head=head)
-      end if
-      if (rp_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
-        call lv%linmap%mat_U2V%print(fname,head=head)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
-        call lv%linmap%mat_V2U%print(fname,head=head)
-      end if
-      if (tprol_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
-        !
-        call lv%tprol%print(fname,head=head)
-      end if
-    end if
-  end if
   
-  if (level >= 1) then 
-    if (allocated(lv%sm)) then
-      call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
-           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+contains
+  module subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
+       & smoother,solver,tprol,global_num)
+    implicit none 
+    class(amg_d_onelev_type), intent(in) :: lv
+    integer(psb_ipk_), intent(in)          :: level
+    integer(psb_ipk_), intent(out)         :: info
+    character(len=*), intent(in), optional :: prefix, head
+    logical, optional, intent(in)    :: ac, rp, smoother, solver, tprol, global_num
+    ! Local variables
+    integer(psb_ipk_)   :: i, j, il1, iln, lname, lev, ni
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: iam, np
+    character(len=80)   :: prefix_, frmt
+    character(len=1024) :: fname 
+    logical :: ac_, rp_, tprol_, global_num_
+    integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
+
+    info = 0
+
+    if (present(prefix)) then 
+      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+    else
+      prefix_ = "dump_lev_d"
     end if
-    if (allocated(lv%sm2a)) then
-      call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
-           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+
+    if (associated(lv%base_desc)) then 
+      ctxt = lv%base_desc%get_context()
+      call psb_info(ctxt,iam,np)
+    else 
+      iam     = -1
+      np      = -1
     end if
-  end if
-  
-end subroutine amg_d_base_onelev_dump
+    if (present(ac)) then 
+      ac_ = ac
+    else
+      ac_ = .false. 
+    end if
+    if (present(rp)) then 
+      rp_ = rp
+    else
+      rp_ = .false. 
+    end if
+    if (present(tprol)) then 
+      tprol_ = tprol
+    else
+      tprol_ = .false. 
+    end if
+    if (present(global_num)) then 
+      global_num_ = global_num
+    else
+      global_num_ = .false. 
+    end if
+    lname = len_trim(prefix_)
+    fname = trim(prefix_)
+
+    if (np > 0) then 
+      ni  = floor(log10(1.0*np)) + 1
+      write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
+      write(fname(lname+1:lname+ni+2),frmt) '_p',iam
+      lname = lname + ni + 2
+    end if
+
+    if (global_num_) then
+      if (level == 1) then
+        if (ac_) then
+          ivr = lv%base_desc%get_global_indices(owned=.false.)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+          call lv%base_a%print(fname,head=head,iv=ivr)
+        end if
+      else if (level >= 2) then 
+        if (ac_) then
+          ivr = lv%desc_ac%get_global_indices(owned=.false.)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+          call lv%ac%print(fname,head=head,iv=ivr)
+        end if
+        if (rp_) then 
+          ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
+          ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
+          call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
+          call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
+        end if
+        if (tprol_) then
+          ! Tentative prolongator is stored with column indices already
+          ! in global numbering, so only IVR is needed. 
+          ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
+          !
+          call lv%tprol%print(fname,head=head,ivr=ivr)
+        end if
+      end if
+    else
+      if (level == 1) then
+        if (ac_) then
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+          call lv%base_a%print(fname,head=head)
+        end if
+      else  if (level >= 2) then 
+        if (ac_) then 
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+          call lv%ac%print(fname,head=head)
+        end if
+        if (rp_) then 
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
+          call lv%linmap%mat_U2V%print(fname,head=head)
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
+          call lv%linmap%mat_V2U%print(fname,head=head)
+        end if
+        if (tprol_) then 
+          write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
+          !
+          call lv%tprol%print(fname,head=head)
+        end if
+      end if
+    end if
+
+    if (level >= 1) then 
+      if (allocated(lv%sm)) then
+        call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
+             & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+      end if
+      if (allocated(lv%sm2a)) then
+        call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
+             & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+      end if
+    end if
+
+  end subroutine amg_d_base_onelev_dump
+end submodule amg_d_base_onelev_dump_impl

amgprec/impl/level/amg_d_base_onelev_free.f90

@@ -35,41 +35,43 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_free(lv,info)
-  
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_free_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_free
-  implicit none 
+  
+contains
+  module subroutine amg_d_base_onelev_free(lv,info)
+    implicit none 
 
-  class(amg_d_onelev_type), intent(inout) :: lv
-  integer(psb_ipk_), intent(out)          :: info
-  integer(psb_ipk_) :: i
+    class(amg_d_onelev_type), intent(inout) :: lv
+    integer(psb_ipk_), intent(out)          :: info
+    integer(psb_ipk_) :: i
 
-  info = psb_success_
+    info = psb_success_
 
-  ! We might just deallocate the top level array, except 
-  ! that there may be inner objects containing C pointers,
-  ! e.g.  UMFPACK, SLU or CUDA stuff.
-  ! We really need FINALs. 
-  if (allocated(lv%sm)) &
-       & call lv%sm%free(info)
+    ! We might just deallocate the top level array, except 
+    ! that there may be inner objects containing C pointers,
+    ! e.g.  UMFPACK, SLU or CUDA stuff.
+    ! We really need FINALs. 
+    if (allocated(lv%sm)) &
+         & call lv%sm%free(info)
 
-  if (allocated(lv%sm2a)) &
-       & call lv%sm2a%free(info)
+    if (allocated(lv%sm2a)) &
+         & call lv%sm2a%free(info)
 
-  if (allocated(lv%wrk)) &
-       & call lv%wrk%free(info)
+    if (allocated(lv%wrk)) &
+         & call lv%wrk%free(info)
 
-  call lv%ac%free()
-  if (lv%desc_ac%is_ok()) &
-       & call lv%desc_ac%free(info)
-  call lv%linmap%free(info)
+    call lv%ac%free()
+    if (lv%desc_ac%is_ok()) &
+         & call lv%desc_ac%free(info)
+    call lv%linmap%free(info)
 
-  ! This is a pointer to something else, must not free it here. 
-  nullify(lv%base_a) 
-  ! This is a pointer to something else, must not free it here. 
-  nullify(lv%base_desc) 
+    ! This is a pointer to something else, must not free it here. 
+    nullify(lv%base_a) 
+    ! This is a pointer to something else, must not free it here. 
+    nullify(lv%base_desc) 
 
-  call lv%nullify()
+    call lv%nullify()
 
-end subroutine amg_d_base_onelev_free
+  end subroutine amg_d_base_onelev_free
+end submodule amg_d_base_onelev_free_impl

amgprec/impl/level/amg_d_base_onelev_free_smoothers.f90

@@ -35,26 +35,28 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_free_smoothers(lv,info)
-  
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_dree_smoothers_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_free_smoothers
-  implicit none 
+  
+contains
+  module subroutine amg_d_base_onelev_free_smoothers(lv,info)
+    implicit none 
 
-  class(amg_d_onelev_type), intent(inout) :: lv
-  integer(psb_ipk_), intent(out)          :: info
-  integer(psb_ipk_) :: i
+    class(amg_d_onelev_type), intent(inout) :: lv
+    integer(psb_ipk_), intent(out)          :: info
+    integer(psb_ipk_) :: i
 
-  info = psb_success_
+    info = psb_success_
 
-  ! We might just deallocate the top level array, except 
-  ! that there may be inner objects containing C pointers,
-  ! e.g.  UMFPACK, SLU or CUDA stuff.
-  ! We really need FINALs. 
-  if (allocated(lv%sm)) &
-       & call lv%sm%free(info)
+    ! We might just deallocate the top level array, except 
+    ! that there may be inner objects containing C pointers,
+    ! e.g.  UMFPACK, SLU or CUDA stuff.
+    ! We really need FINALs. 
+    if (allocated(lv%sm)) &
+         & call lv%sm%free(info)
 
-  if (allocated(lv%sm2a)) &
-       & call lv%sm2a%free(info)
+    if (allocated(lv%sm2a)) &
+         & call lv%sm2a%free(info)
 
-end subroutine amg_d_base_onelev_free_smoothers
+  end subroutine amg_d_base_onelev_free_smoothers
+end submodule amg_d_base_onelev_dree_smoothers_impl

amgprec/impl/level/amg_d_base_onelev_map_prol.F90

@@ -35,101 +35,113 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
-  use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_map_prol_v
-  
-  implicit none
-  class(amg_d_onelev_type), target, intent(inout) :: lv
-  real(psb_dpk_), intent(in)           :: alpha, beta
-  type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
-  integer(psb_ipk_), intent(out)       :: info
-  real(psb_dpk_), optional          :: work(:)
-  type(psb_d_vect_type), optional, target, intent(inout)  :: vtx,vty
-  
-!!$  write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
-  if (lv%remap_data%ac_pre_remap%is_asb()) then
-    !
-    ! Remap has happened, deal with it
-    !
-!!$    write(0,*) 'Remap handling '
-    block
-      type(psb_ctxt_type) :: ctxt, nctxt
-      integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
-      integer(psb_mpk_) :: me, np,  rme, rnp
-      real(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
-      type(psb_d_vect_type) :: tv
 
-      ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
-      call psb_info(ctxt,me,np)
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_map_prol_impl
+  use psb_base_mod
+  
+contains
+  module subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
+    implicit none
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    real(psb_dpk_), intent(in)           :: alpha, beta
+    type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
+    integer(psb_ipk_), intent(out)       :: info
+    real(psb_dpk_), optional          :: work(:)
+    type(psb_d_vect_type), optional, target, intent(inout)  :: vtx,vty
+
+    type(psb_d_vect_type), pointer   :: vtx_
+
+!!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
+    if (present(vtx)) then
+      vtx_ => vtx
+    else
+      vtx_ => lv%wrk%wv(1)
+    end if
+
+!!$  write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
+    if (lv%remap_data%ac_pre_remap%is_asb()) then
+      !
+      ! Remap has happened, deal with it
+      !
+!!$    write(0,*) 'Remap handling '
+      block
+        type(psb_ctxt_type) :: ctxt, nctxt
+        integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
+        integer(psb_mpk_) :: me, np,  rme, rnp
+real(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
+        type(psb_d_vect_type) :: tv
+
+        ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
+        call psb_info(ctxt,me,np)
 !!$      write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
-      nctxt = lv%desc_ac%get_ctxt()
-      call psb_info(nctxt,rme,rnp)
+        nctxt = lv%desc_ac%get_ctxt()
+        call psb_info(nctxt,rme,rnp)
 !!$      write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
-      idest = lv%remap_data%idest
-      associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
+        idest = lv%remap_data%idest
+        associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
 !!$        write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
-        nsrc = size(isrc)
-        nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
-        nrc  = lv%remap_data%desc_ac_pre_remap%get_local_cols()
-        if (rme >=0) then
-          allocate(rrcv(sum(nrsrc)))
-          rrcv   = vect_v%get_vect()
+          nsrc = size(isrc)
+          nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
+          nrc  = lv%remap_data%desc_ac_pre_remap%get_local_cols()
+          if (rme >=0) then
+            allocate(rrcv(sum(nrsrc)))
+            rrcv   = vect_v%get_vect()
 !!$          write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
-          kp = 0
-          do i = 1,size(isrc)
-            ip = isrc(i)
-            nrl = nrsrc(i)
+            kp = 0
+            do i = 1,size(isrc)
+              ip = isrc(i)
+              nrl = nrsrc(i)
 !!$            write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
-            call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
-            kp = kp + nrl
-          end do
-        end if
-        nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
-        call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
+              call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
+              kp = kp + nrl
+            end do
+          end if
+          nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
+          call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
 !!$        write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
-        
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
+
+          call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
 !!$        write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
 !!$        write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
-        call psb_realloc(nrc,rsnd,info)
-        call psb_rcv(ctxt,rsnd(1:nrl),idest)
-        call tv%set_vect(rsnd)
-        call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
-             & work=work,vtx=vtx,vty=vty)
-      end associate
+!!$        call psb_realloc(nrc,rsnd,info)
+!!$        call psb_rcv(ctxt,rsnd(1:nrl),idest)
+!!$        call tv%set_vect(rsnd)
+          call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
+          call tv%set_host()
+          call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
+               & work=work,vtx=vtx_,vty=vty)
+        end associate
 !!$      write(0,*) me, ' Prolongator with remap done '
 !!$      flush(0)
 !!$      call psb_barrier(ctxt)
-    end block
-  else
-    ! Default transfer
-    call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
-         & work=work,vtx=vtx,vty=vty)
-  end if
-  
-end subroutine amg_d_base_onelev_map_prol_v
+      end block
+    else
+      ! Default transfer
+      call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
+           & work=work,vtx=vtx_,vty=vty)
+    end if
 
-subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
-  use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_map_prol_a
-  implicit none
-  class(amg_d_onelev_type), target, intent(inout) :: lv
-  real(psb_dpk_), intent(in)     :: alpha, beta
-  real(psb_dpk_), intent(inout)   :: u(:)
-  real(psb_dpk_), intent(out)     :: v(:)
-  integer(psb_ipk_), intent(out) :: info
-  real(psb_dpk_), optional          :: work(:)
+  end subroutine amg_d_base_onelev_map_prol_v
 
-  if (lv%remap_data%ac_pre_remap%is_asb()) then
-    !
-    ! Remap has happened, deal with it
-    !
-    write(0,*) 'Remap handling not implemented yet '
-  else
-    ! Default transfer
-    call lv%linmap%map_V2U(alpha,v,beta,u,info,&
-         & work=work)
-  end if
-  
-end subroutine amg_d_base_onelev_map_prol_a
+  module subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+    implicit none
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    real(psb_dpk_), intent(in)     :: alpha, beta
+    real(psb_dpk_), intent(inout)   :: u(:)
+    real(psb_dpk_), intent(out)     :: v(:)
+    integer(psb_ipk_), intent(out) :: info
+    real(psb_dpk_), optional          :: work(:)
+
+    if (lv%remap_data%ac_pre_remap%is_asb()) then
+      !
+      ! Remap has happened, deal with it
+      !
+      write(0,*) 'Remap P handling not implemented yet for A'
+    else
+      ! Default transfer
+      call lv%linmap%map_V2U(alpha,v,beta,u,info,&
+           & work=work)
+    end if
+
+  end subroutine amg_d_base_onelev_map_prol_a
+end submodule amg_d_base_onelev_map_prol_impl

amgprec/impl/level/amg_d_base_onelev_map_rstr.F90

@@ -36,94 +36,115 @@
 !   
 !  
 
-subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
-     &  work,vtx,vty)
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_map_rstr_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_map_rstr_v
-  implicit none
-  class(amg_d_onelev_type), target, intent(inout) :: lv
-  real(psb_dpk_), intent(in)           :: alpha, beta
-  type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
-  integer(psb_ipk_), intent(out)       :: info
-  real(psb_dpk_), optional          :: work(:)
-  type(psb_d_vect_type), optional, target, intent(inout)  :: vtx,vty
+  
+contains
+  module subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
+       &  work,vtx,vty)
+    implicit none
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    real(psb_dpk_), intent(in)           :: alpha, beta
+    type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
+    integer(psb_ipk_), intent(out)       :: info
+    real(psb_dpk_), optional          :: work(:)
+    type(psb_d_vect_type), optional, target, intent(inout)  :: vtx,vty
+    type(psb_d_vect_type), pointer   :: vty_
+    integer(psb_mpk_) :: me, np
 
 !!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-  if (lv%remap_data%ac_pre_remap%is_asb()) then
-    !
-    ! Remap has happened, deal with it
-    !
+    if (present(vty)) then
+      vty_ => vty
+    else
+      vty_ => lv%wrk%wv(1)
+    end if
+
+    if (lv%remap_data%ac_pre_remap%is_asb()) then
+      !
+      ! Remap has happened, deal with it
+      !
 !!$    write(0,*) 'Remap handling not implemented yet '
-    block
-      type(psb_ctxt_type) :: ctxt, nctxt
-      integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
-      integer(psb_mpk_) :: me, np,  rme, rnp
-      real(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
-      type(psb_d_vect_type) :: tv
-      
-      ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
-      call psb_info(ctxt,me,np)
-      nctxt = lv%desc_ac%get_ctxt()
-      call psb_info(nctxt,rme,rnp)
-!!$      write(0,*) 'New context ',rme,rnp
-      idest = lv%remap_data%idest
-      associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
+      block
+        type(psb_ctxt_type) :: ctxt, rctxt
+        integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
+        integer(psb_mpk_) :: rme, rnp
+real(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
+        type(psb_d_vect_type) :: tv
+
+        ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
+        call psb_info(ctxt,me,np)
+        rctxt = lv%desc_ac%get_ctxt()
+        call psb_info(rctxt,rme,rnp)
+!!$      write(0,*) 'New context map rstr',rme,rnp,me,np
+        idest = lv%remap_data%idest
+        associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
 !!$        write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
 !!$        if (rme >= 0) write(0,*) rme, '  Receiving      data from ',isrc(:)
-        nsrc = size(isrc)
-        nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
-        call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
-!!$        write(0,*) me,' Size of TV ',tv%get_nrows()
-        call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
-             & work=work,vtx=vtx,vty=vty)
-        rsnd = tv%get_vect()
-        call psb_snd(ctxt,rsnd(1:nrl),idest)
-        if (rme >=0) then
-          allocate(rrcv(sum(nrsrc)))
+          nsrc = size(isrc)
+          nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
+          call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
+          call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
+!!$        write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),&
+!!$             & psb_errstatus_fatal()
+!!$        flush(0)
+          call psb_barrier(ctxt)
+          call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
+               & work=work,vtx=vtx,vty=vty_)
+          call tv%sync()
+          !rsnd = tv%get_vect()
+          !call psb_snd(ctxt,rsnd(1:nrl),idest) 
+!!$        write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal()
+          call psb_snd(ctxt,tv%v%v(1:nrl),idest)
+          if (rme >=0) then
+            allocate(rrcv(sum(nrsrc)))
 !!$          write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
-          kp = 0
-          do i = 1,size(isrc)
-            ip = isrc(i)
-            nrl = nrsrc(i)
-!!$            write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
-            call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
-            kp = kp + nrl
-          end do
-          call vect_v%set_vect(rrcv)
-        end if
-      end associate
-!!$      write(0,*) me, ' Restrictor with remap done '
-    end block
- 
-  else
-    ! Default transfer
-    call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
-         & work=work,vtx=vtx,vty=vty)
-  end if
-  
-end subroutine amg_d_base_onelev_map_rstr_v
+            kp = 0
+            do i = 1,size(isrc)
+              ip = isrc(i)
+              nrl = nrsrc(i)
+!!$            write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal()           
+              call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
+              kp = kp + nrl
+            end do
+            call vect_v%set_vect(rrcv)
+          end if
+        end associate
+!!$      write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal()     
+      end block
 
-subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
-  use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_map_rstr_a
-  implicit none
-  class(amg_d_onelev_type), target, intent(inout) :: lv
-  real(psb_dpk_), intent(in)     :: alpha, beta
-  real(psb_dpk_), intent(inout)   :: u(:)
-  real(psb_dpk_), intent(out)     :: v(:)
-  integer(psb_ipk_), intent(out) :: info
-  real(psb_dpk_), optional       :: work(:)
+    else
+      ! Default transfer
+      block
+        type(psb_ctxt_type) :: ctxt, rctxt
+        ctxt = lv%linmap%p_desc_U%get_ctxt()
+        call psb_info(ctxt,me,np)
+!!$      write(0,*) me,' map_rstr calling U2V: ',me,np
+        call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
+             & work=work,vtx=vtx,vty=vty_)
+      end block
+    end if
+!!$  write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal()  
+  end subroutine amg_d_base_onelev_map_rstr_v
 
-  if (lv%remap_data%ac_pre_remap%is_asb()) then
-    !
-    ! Remap has happened, deal with it
-    !
-    write(0,*) 'Remap handling not implemented yet '
-  else
-    ! Default transfer
-    call lv%linmap%map_U2V(alpha,u,beta,v,info,&
-         & work=work)
-  end if
-  
-end subroutine amg_d_base_onelev_map_rstr_a
+  module subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+    implicit none
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    real(psb_dpk_), intent(in)     :: alpha, beta
+    real(psb_dpk_), intent(inout)   :: u(:)
+    real(psb_dpk_), intent(out)     :: v(:)
+    integer(psb_ipk_), intent(out) :: info
+    real(psb_dpk_), optional       :: work(:)
+
+    if (lv%remap_data%ac_pre_remap%is_asb()) then
+      !
+      ! Remap has happened, deal with it
+      !
+      write(0,*) 'Remap R handling not implemented yet for A'
+    else
+      ! Default transfer
+      call lv%linmap%map_U2V(alpha,u,beta,v,info,&
+           & work=work)
+    end if
+
+  end subroutine amg_d_base_onelev_map_rstr_a
+end submodule amg_d_base_onelev_map_rstr_impl

amgprec/impl/level/amg_d_base_onelev_mat_asb.f90

@@ -83,109 +83,111 @@
 !    info    -  integer, output.
 !               Error code.         
 !  
-subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
-
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_mat_asb_impl
   use psb_base_mod
   use amg_base_prec_type
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_mat_asb
-
-  implicit none
-
-  ! Arguments
-  class(amg_d_onelev_type), intent(inout), target :: lv
-  type(psb_dspmat_type), intent(in)  :: a
-  type(psb_desc_type), intent(inout)   :: desc_a
-  integer(psb_lpk_), intent(inout) :: nlaggr(:)
-  integer(psb_lpk_), intent(inout) :: ilaggr(:)
-  type(psb_ldspmat_type), intent(inout)  :: t_prol
-  integer(psb_ipk_), intent(out)      :: info
   
+contains
+  module subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
 
-  ! Local variables
-  character(len=24)        :: name
-  type(psb_ctxt_type)      :: ctxt
-  integer(psb_ipk_)        :: np, me
-  integer(psb_ipk_)        :: err_act
-  type(psb_dspmat_type)    :: ac, op_restr, op_prol
-  integer(psb_ipk_)        :: nzl, inl
-  integer(psb_ipk_)        :: debug_level, debug_unit
-  integer(psb_ipk_), save  :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
-  logical, parameter :: do_timings=.false.
+    implicit none
 
-  name='amg_d_onelev_mat_asb'
-  call psb_erractionsave(err_act)
-  if (psb_errstatus_fatal()) then
-    info = psb_err_internal_error_; goto 9999
-  end if
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  info  = psb_success_
-  ctxt = desc_a%get_context()
-  call psb_info(ctxt,me,np)
-  if ((do_timings).and.(idx_matbld==-1))       &
-       & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
-  if ((do_timings).and.(idx_matasb==-1))     &
-       & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
-  if ((do_timings).and.(idx_mapbld==-1))       &
-       & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
-
-  call amg_check_def(lv%parms%aggr_prol,'Smoother',&
-       &   amg_smooth_prol_,is_legal_ml_aggr_prol)
-  call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
-       &   amg_distr_mat_,is_legal_ml_coarse_mat)
-  call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
-       &   amg_no_filter_mat_,is_legal_aggr_filter)
-  call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
-       &   amg_eig_est_,is_legal_ml_aggr_omega_alg)
-  call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
-       &   amg_max_norm_,is_legal_ml_aggr_eig)
-  call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega)
+    ! Arguments
+    class(amg_d_onelev_type), intent(inout), target :: lv
+    type(psb_dspmat_type), intent(in)  :: a
+    type(psb_desc_type), intent(inout)   :: desc_a
+    integer(psb_lpk_), intent(inout) :: nlaggr(:)
+    integer(psb_lpk_), intent(inout) :: ilaggr(:)
+    type(psb_ldspmat_type), intent(inout)  :: t_prol
+    integer(psb_ipk_), intent(out)      :: info
 
 
-  !
-  ! Build the coarse-level matrix from the fine-level one, starting from 
-  ! the mapping defined by amg_aggrmap_bld and applying the aggregation
-  ! algorithm specified by lv%iprcparm(amg_aggr_prol_)
-  !
-  if (do_timings) call psb_tic(idx_matbld)
-  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
-       & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
-  if (do_timings) call psb_toc(idx_matbld)
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
-    goto 9999
-  end if
+    ! Local variables
+    character(len=24)        :: name
+    type(psb_ctxt_type)      :: ctxt
+    integer(psb_ipk_)        :: np, me
+    integer(psb_ipk_)        :: err_act
+    type(psb_dspmat_type)    :: ac, op_restr, op_prol
+    integer(psb_ipk_)        :: nzl, inl
+    integer(psb_ipk_)        :: debug_level, debug_unit
+    integer(psb_ipk_), save  :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
+    logical, parameter :: do_timings=.false.
 
-  !
-  ! Now build its descriptor and convert global indices for
-  ! ac, op_restr and op_prol
-  !
-  if (do_timings) call psb_tic(idx_matasb)
-  if (info == psb_success_) &
-       & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
-       & lv%ac,lv%desc_ac,op_prol,op_restr,info)
-  if (do_timings) call psb_toc(idx_matasb)
-  if (do_timings) call psb_tic(idx_mapbld)  
-  if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
-  
-  if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
-       & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
-  if (do_timings) call psb_toc(idx_mapbld)  
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
-    goto 9999
-  end if
-  !
-  ! Fix the base_a and base_desc pointers for handling of residuals.
-  ! This is correct because this routine is only called at levels >=2.
-  !
-  lv%base_a    => lv%ac
-  lv%base_desc => lv%desc_ac
+    name='amg_d_onelev_mat_asb'
+    call psb_erractionsave(err_act)
+    if (psb_errstatus_fatal()) then
+      info = psb_err_internal_error_; goto 9999
+    end if
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    info  = psb_success_
+    ctxt = desc_a%get_context()
+    call psb_info(ctxt,me,np)
+    if ((do_timings).and.(idx_matbld==-1))       &
+         & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
+    if ((do_timings).and.(idx_matasb==-1))     &
+         & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
+    if ((do_timings).and.(idx_mapbld==-1))       &
+         & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
 
-  call psb_erractionrestore(err_act)
-  return
+    call amg_check_def(lv%parms%aggr_prol,'Smoother',&
+         &   amg_smooth_prol_,is_legal_ml_aggr_prol)
+    call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
+         &   amg_distr_mat_,is_legal_ml_coarse_mat)
+    call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
+         &   amg_no_filter_mat_,is_legal_aggr_filter)
+    call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
+         &   amg_eig_est_,is_legal_ml_aggr_omega_alg)
+    call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
+         &   amg_max_norm_,is_legal_ml_aggr_eig)
+    call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega)
+
+
+    !
+    ! Build the coarse-level matrix from the fine-level one, starting from 
+    ! the mapping defined by amg_aggrmap_bld and applying the aggregation
+    ! algorithm specified by lv%iprcparm(amg_aggr_prol_)
+    !
+    if (do_timings) call psb_tic(idx_matbld)
+    call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
+         & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
+    if (do_timings) call psb_toc(idx_matbld)
+    if(info /= psb_success_) then
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
+      goto 9999
+    end if
+
+    !
+    ! Now build its descriptor and convert global indices for
+    ! ac, op_restr and op_prol
+    !
+    if (do_timings) call psb_tic(idx_matasb)
+    if (info == psb_success_) &
+         & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
+         & lv%ac,lv%desc_ac,op_prol,op_restr,info)
+    if (do_timings) call psb_toc(idx_matasb)
+    if (do_timings) call psb_tic(idx_mapbld)  
+    if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
+
+    if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
+         & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
+    if (do_timings) call psb_toc(idx_mapbld)  
+    if(info /= psb_success_) then
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
+      goto 9999
+    end if
+    !
+    ! Fix the base_a and base_desc pointers for handling of residuals.
+    ! This is correct because this routine is only called at levels >=2.
+    !
+    lv%base_a    => lv%ac
+    lv%base_desc => lv%desc_ac
+
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_d_base_onelev_mat_asb
+  end subroutine amg_d_base_onelev_mat_asb
+end submodule amg_d_base_onelev_mat_asb_impl

amgprec/impl/level/amg_d_base_onelev_memory_use.f90

@@ -42,109 +42,112 @@
 !         0: normal
 !        >1: increased details 
 !
-subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
-
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_memory_use_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_memory_use
-  Implicit None
-  ! Arguments
-  class(amg_d_onelev_type), intent(in)    :: lv
-  integer(psb_ipk_), intent(in)           :: il,nl,ilmin
-  integer(psb_ipk_), intent(out)          :: info
-  integer(psb_ipk_), intent(in), optional :: iout
-  character(len=*), intent(in), optional  :: prefix
-      integer(psb_ipk_), intent(in), optional :: verbosity
-  logical, intent(in), optional           :: global
-
-
-  ! Local variables
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)  :: err_act ,me, np
-  character(len=20), parameter :: name='amg_d_base_onelev_memory_use'
-  integer(psb_ipk_)  :: iout_, verbosity_
-  logical      :: coarse, global_
-  character(1024)    :: prefix_
-  integer(psb_epk_), allocatable  :: sz(:)
-
-
-  call psb_erractionsave(err_act)
-
-  ctxt = lv%base_desc%get_ctxt()
-  call psb_info(ctxt,me,np)
   
-  coarse = (il==nl)
+contains
+  module subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,&
+       & iout,verbosity,prefix,global)
+    Implicit None
+    ! Arguments
+    class(amg_d_onelev_type), intent(in)    :: lv
+    integer(psb_ipk_), intent(in)           :: il,nl,ilmin
+    integer(psb_ipk_), intent(out)          :: info
+    integer(psb_ipk_), intent(in), optional :: iout
+    character(len=*), intent(in), optional  :: prefix
+    integer(psb_ipk_), intent(in), optional :: verbosity
+    logical, intent(in), optional           :: global
 
-  if (present(iout)) then 
-    iout_ = iout
-  else 
-    iout_ = psb_out_unit
-  end if
 
-  if (present(verbosity)) then
-    verbosity_ = verbosity
-  else
-    verbosity_ = 0
-  end if
-  if (verbosity_ < 0) goto 9998
-  if (present(global)) then
-    global_ = global
-  else
-    global_ = .true.
-  end if
+    ! Local variables
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)  :: err_act ,me, np
+    character(len=20), parameter :: name='amg_d_base_onelev_memory_use'
+    integer(psb_ipk_)  :: iout_, verbosity_
+    logical      :: coarse, global_
+    character(1024)    :: prefix_
+    integer(psb_epk_), allocatable  :: sz(:)
 
-  if (present(prefix)) then
-    prefix_ = prefix
-  else
-    prefix_ = ""
-  end if
 
-  if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
+    call psb_erractionsave(err_act)
 
-  if (global_) then
-    allocate(sz(6))
-    sz(:) = 0 
-    sz(1) =  lv%base_a%sizeof()
-    sz(2) =  lv%base_desc%sizeof()
-    if (il >1)              sz(3) =  lv%linmap%sizeof()
-    if (allocated(lv%sm))   sz(4) =  lv%sm%sizeof()
-    if (allocated(lv%sm2a)) sz(5) =  lv%sm2a%sizeof()
-    if (allocated(lv%wrk))  sz(6) =  lv%wrk%sizeof()
-    call psb_sum(ctxt,sz)
-    if (me == 0) then 
-      if (coarse)  then 
-        write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
-      else
-        write(iout_,*) trim(prefix_), ' Level ',il
-      end if
-      write(iout_,*) trim(prefix_), '           Matrix:',                         sz(1) 
-      write(iout_,*) trim(prefix_), '       Descriptor:',                         sz(2) 
-      if (il >1) write(iout_,*) trim(prefix_), '       Linear map:',              sz(3) 
-      if (allocated(lv%sm)) write(iout_,*) trim(prefix_), '         Smoother:',   sz(4) 
-      if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), '       Smoother 2:', sz(5) 
-      if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), '        Workspace:',  sz(6)
+    ctxt = lv%base_desc%get_ctxt()
+    call psb_info(ctxt,me,np)
+
+    coarse = (il==nl)
+
+    if (present(iout)) then 
+      iout_ = iout
+    else 
+      iout_ = psb_out_unit
     end if
-    
-  else
-    if ((me == 0).or.(verbosity_>0)) then 
-      if (coarse)  then 
-        write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
-      else
-        write(iout_,*) trim(prefix_), ' Level ',il
-      end if
-      write(iout_,*) trim(prefix_), '           Matrix:', lv%base_a%sizeof()
-      write(iout_,*) trim(prefix_), '       Descriptor:', lv%base_desc%sizeof()
-      if (il >1) write(iout_,*) trim(prefix_), '       Linear map:', lv%linmap%sizeof()
-      if (allocated(lv%sm)) write(iout_,*) trim(prefix_), '         Smoother:', lv%sm%sizeof()
-      if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), '       Smoother 2:', lv%sm2a%sizeof()
-      if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), '        Workspace:', lv%wrk%sizeof()
+
+    if (present(verbosity)) then
+      verbosity_ = verbosity
+    else
+      verbosity_ = 0
     end if
-  endif
+    if (verbosity_ < 0) goto 9998
+    if (present(global)) then
+      global_ = global
+    else
+      global_ = .true.
+    end if
+
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
+    if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
+
+    if (global_) then
+      allocate(sz(6))
+      sz(:) = 0 
+      sz(1) =  lv%base_a%sizeof()
+      sz(2) =  lv%base_desc%sizeof()
+      if (il >1)              sz(3) =  lv%linmap%sizeof()
+      if (allocated(lv%sm))   sz(4) =  lv%sm%sizeof()
+      if (allocated(lv%sm2a)) sz(5) =  lv%sm2a%sizeof()
+      if (allocated(lv%wrk))  sz(6) =  lv%wrk%sizeof()
+      call psb_sum(ctxt,sz)
+      if (me == 0) then 
+        if (coarse)  then 
+          write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
+        else
+          write(iout_,*) trim(prefix_), ' Level ',il
+        end if
+        write(iout_,*) trim(prefix_), '           Matrix:',                         sz(1) 
+        write(iout_,*) trim(prefix_), '       Descriptor:',                         sz(2) 
+        if (il >1) write(iout_,*) trim(prefix_), '       Linear map:',              sz(3) 
+        if (allocated(lv%sm)) write(iout_,*) trim(prefix_), '         Smoother:',   sz(4) 
+        if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), '       Smoother 2:', sz(5) 
+        if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), '        Workspace:',  sz(6)
+      end if
+
+    else
+      if ((me == 0).or.(verbosity_>0)) then 
+        if (coarse)  then 
+          write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
+        else
+          write(iout_,*) trim(prefix_), ' Level ',il
+        end if
+        write(iout_,*) trim(prefix_), '           Matrix:', lv%base_a%sizeof()
+        write(iout_,*) trim(prefix_), '       Descriptor:', lv%base_desc%sizeof()
+        if (il >1) write(iout_,*) trim(prefix_), '       Linear map:', lv%linmap%sizeof()
+        if (allocated(lv%sm)) write(iout_,*) trim(prefix_), '         Smoother:', lv%sm%sizeof()
+        if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), '       Smoother 2:', lv%sm2a%sizeof()
+        if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), '        Workspace:', lv%wrk%sizeof()
+      end if
+    endif
 
 9998 continue
-  call psb_erractionrestore(err_act)
-  return
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
-  return
+    return
 
-end subroutine amg_d_base_onelev_memory_use
+  end subroutine amg_d_base_onelev_memory_use
+end submodule amg_d_base_onelev_memory_use_impl

amgprec/impl/level/amg_d_base_onelev_setag.f90

@@ -35,48 +35,50 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_setag(lv,val,info,pos)
-
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_setag_impl
   use psb_base_mod
-  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_setag
-
-  implicit none
-
-  ! Arguments
-  class(amg_d_onelev_type), target, intent(inout) :: lv
-  class(amg_d_base_aggregator_type), intent(in)   :: val
-  integer(psb_ipk_), intent(out)                  :: info
-  character(len=*), optional, intent(in)          :: pos
   
-  ! Local variables
-  integer(psb_ipk_)                :: ipos_
-  character(len=*), parameter      :: name='amg_base_onelev_setag'
+contains
+  module subroutine amg_d_base_onelev_setag(lv,val,info,pos)
 
-  info = psb_success_
+    implicit none
 
-  ! Ignore pos for aggregator
-  
-  if (allocated(lv%aggr)) then 
-    if (.not.same_type_as(lv%aggr,val))  then
-      call lv%aggr%free(info)
-      deallocate(lv%aggr,stat=info)
+    ! Arguments
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    class(amg_d_base_aggregator_type), intent(in)   :: val
+    integer(psb_ipk_), intent(out)                  :: info
+    character(len=*), optional, intent(in)          :: pos
+
+    ! Local variables
+    integer(psb_ipk_)                :: ipos_
+    character(len=*), parameter      :: name='amg_base_onelev_setag'
+
+    info = psb_success_
+
+    ! Ignore pos for aggregator
+
+    if (allocated(lv%aggr)) then 
+      if (.not.same_type_as(lv%aggr,val))  then
+        call lv%aggr%free(info)
+        deallocate(lv%aggr,stat=info)
+        if (info /= 0) then
+          info = 3111
+          return
+        end if
+      end if
+    end if
+
+    if (.not.allocated(lv%aggr)) then 
+      allocate(lv%aggr,mold=val,stat=info) 
       if (info /= 0) then
         info = 3111
         return
       end if
+      lv%parms%par_aggr_alg  = amg_ext_aggr_
+      lv%parms%aggr_type     = amg_noalg_
+      call lv%aggr%default()
     end if
-  end if
-      
-  if (.not.allocated(lv%aggr)) then 
-    allocate(lv%aggr,mold=val,stat=info) 
-    if (info /= 0) then
-      info = 3111
-      return
-    end if
-    lv%parms%par_aggr_alg  = amg_ext_aggr_
-    lv%parms%aggr_type     = amg_noalg_
-    call lv%aggr%default()
-  end if
-  
-end subroutine amg_d_base_onelev_setag
 
+  end subroutine amg_d_base_onelev_setag
+
+end submodule amg_d_base_onelev_setag_impl

amgprec/impl/level/amg_d_base_onelev_setsm.F90

@@ -35,72 +35,73 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_setsm(lev,val,info,pos)
-
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_setsm_impl
   use psb_base_mod
-  use amg_d_prec_mod, amg_protect_name => amg_d_base_onelev_setsm
-
-  implicit none
-
-  ! Arguments
-  class(amg_d_onelev_type), target, intent(inout) :: lev
-  class(amg_d_base_smoother_type), intent(in)  :: val
-  integer(psb_ipk_), intent(out)               :: info
-  character(len=*), optional, intent(in)       :: pos
   
-  ! Local variables
-  integer(psb_ipk_)                      :: ipos_
-  character(len=*), parameter            :: name='amg_base_onelev_setsm'
-  
-  info = psb_success_
+contains
+  module subroutine amg_d_base_onelev_setsm(lv,val,info,pos)
+    implicit none
 
-  if (present(pos)) then
-    select case(psb_toupper(trim(pos)))
-    case('PRE')
-      ipos_ = amg_smooth_pre_
-    case('POST')
-      ipos_ = amg_smooth_post_
-    case default
+    ! Arguments
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    class(amg_d_base_smoother_type), intent(in)  :: val
+    integer(psb_ipk_), intent(out)               :: info
+    character(len=*), optional, intent(in)       :: pos
+
+    ! Local variables
+    integer(psb_ipk_)                      :: ipos_
+    character(len=*), parameter            :: name='amg_base_onelev_setsm'
+
+    info = psb_success_
+
+    if (present(pos)) then
+      select case(psb_toupper(trim(pos)))
+      case('PRE')
+        ipos_ = amg_smooth_pre_
+      case('POST')
+        ipos_ = amg_smooth_post_
+      case default
+        ipos_ = amg_smooth_both_
+      end select
+    else
       ipos_ = amg_smooth_both_
-    end select
-  else
-    ipos_ = amg_smooth_both_
-  end if
-
-  if (ipos_ == amg_smooth_both_) then
-    if (allocated(lev%sm2a)) then
-      call lev%sm2a%free(info)
-      deallocate(lev%sm2a, stat=info)
-      lev%sm2 => null()
     end if
-  end if
-     
-  select case(ipos_)
-  case(amg_smooth_pre_, amg_smooth_both_) 
-    if (allocated(lev%sm)) then
-      if (.not.same_type_as(lev%sm,val)) then
-        call lev%sm%free(info)
-        deallocate(lev%sm, stat=info)
+
+    if (ipos_ == amg_smooth_both_) then
+      if (allocated(lv%sm2a)) then
+        call lv%sm2a%free(info)
+        deallocate(lv%sm2a, stat=info)
+        lv%sm2 => null()
       end if
-    endif
-    if (.not.allocated(lev%sm)) then
-      allocate(lev%sm,mold=val) 
     end if
-    call lev%sm%default()        
-    if (ipos_ ==  amg_smooth_both_) lev%sm2 => lev%sm
-  case(amg_smooth_post_) 
-    if (allocated(lev%sm2a)) then
-      if (.not.same_type_as(lev%sm2a,val)) then
-        call lev%sm2a%free(info)
-        deallocate(lev%sm2a, stat=info)
-      endif
-    end if
-    if (.not.allocated(lev%sm2a)) then
-      allocate(lev%sm2a,mold=val) 
-    end if
-    call lev%sm2a%default()
-    lev%sm2 => lev%sm2a
-  end select
-    
-end subroutine amg_d_base_onelev_setsm
 
+    select case(ipos_)
+    case(amg_smooth_pre_, amg_smooth_both_) 
+      if (allocated(lv%sm)) then
+        if (.not.same_type_as(lv%sm,val)) then
+          call lv%sm%free(info)
+          deallocate(lv%sm, stat=info)
+        end if
+      endif
+      if (.not.allocated(lv%sm)) then
+        allocate(lv%sm,mold=val) 
+      end if
+      call lv%sm%default()        
+      if (ipos_ ==  amg_smooth_both_) lv%sm2 => lv%sm
+    case(amg_smooth_post_) 
+      if (allocated(lv%sm2a)) then
+        if (.not.same_type_as(lv%sm2a,val)) then
+          call lv%sm2a%free(info)
+          deallocate(lv%sm2a, stat=info)
+        endif
+      end if
+      if (.not.allocated(lv%sm2a)) then
+        allocate(lv%sm2a,mold=val) 
+      end if
+      call lv%sm2a%default()
+      lv%sm2 => lv%sm2a
+    end select
+
+  end subroutine amg_d_base_onelev_setsm
+
+end submodule amg_d_base_onelev_setsm_impl

amgprec/impl/level/amg_d_base_onelev_setsv.F90

@@ -35,110 +35,111 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_d_base_onelev_setsv(lev,val,info,pos)
-
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_setsv_impl
   use psb_base_mod
-  use amg_d_prec_mod, amg_protect_name => amg_d_base_onelev_setsv
-
-  implicit none
-
-  ! Arguments
-  class(amg_d_onelev_type), target, intent(inout) :: lev
-  class(amg_d_base_solver_type), intent(in)       :: val
-  integer(psb_ipk_), intent(out)                  :: info
-  character(len=*), optional, intent(in)          :: pos
   
-  ! Local variables
-  integer(psb_ipk_)                :: ipos_
-  character(len=*), parameter      :: name='amg_base_onelev_setsv'
+contains
+  module subroutine amg_d_base_onelev_setsv(lv,val,info,pos)
+    implicit none
 
-  info = psb_success_
+    ! Arguments
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    class(amg_d_base_solver_type), intent(in)       :: val
+    integer(psb_ipk_), intent(out)                  :: info
+    character(len=*), optional, intent(in)          :: pos
 
-  if (present(pos)) then
-    select case(psb_toupper(trim(pos)))
-    case('PRE')
-      ipos_ = amg_smooth_pre_
-    case('POST')
-      ipos_ = amg_smooth_post_
-    case default
+    ! Local variables
+    integer(psb_ipk_)                :: ipos_
+    character(len=*), parameter      :: name='amg_base_onelev_setsv'
+
+    info = psb_success_
+
+    if (present(pos)) then
+      select case(psb_toupper(trim(pos)))
+      case('PRE')
+        ipos_ = amg_smooth_pre_
+      case('POST')
+        ipos_ = amg_smooth_post_
+      case default
+        ipos_ = amg_smooth_both_
+      end select
+    else
       ipos_ = amg_smooth_both_
-    end select
-  else
-    ipos_ = amg_smooth_both_
-  end if
-  
-  if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then 
-    if (allocated(lev%sm)) then 
-      if (allocated(lev%sm%sv)) then
-        if (.not.same_type_as(lev%sm%sv,val))  then
-          call lev%sm%sv%free(info)
-          if (info == 0) deallocate(lev%sm%sv,stat=info)
+    end if
+
+    if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then 
+      if (allocated(lv%sm)) then 
+        if (allocated(lv%sm%sv)) then
+          if (.not.same_type_as(lv%sm%sv,val))  then
+            call lv%sm%sv%free(info)
+            if (info == 0) deallocate(lv%sm%sv,stat=info)
+            if (info /= 0) then
+              info = 3111
+              return
+            end if
+          end if
+        end if
+
+        if (.not.allocated(lv%sm%sv)) then 
+          allocate(lv%sm%sv,mold=val,stat=info) 
           if (info /= 0) then
             info = 3111
             return
           end if
         end if
+        call lv%sm%sv%default()
+      else
+        info = 3111
+        write(psb_err_unit,*) name,&
+             &': Error: uninitialized preconditioner component,',&
+             &' should call amg_PRECINIT/amg_PRECSET' 
+        return 
+
       end if
-      
-      if (.not.allocated(lev%sm%sv)) then 
-        allocate(lev%sm%sv,mold=val,stat=info) 
-        if (info /= 0) then
-          info = 3111
-          return
-        end if
-      end if
-      call lev%sm%sv%default()
-    else
-      info = 3111
-      write(psb_err_unit,*) name,&
-           &': Error: uninitialized preconditioner component,',&
-           &' should call amg_PRECINIT/amg_PRECSET' 
-      return 
-      
     end if
-  end if
 
-  !
-  ! If POS was not specified and therefore we have amg_smooth_both_
-  ! we need to update sm2a *only* if it was already allocated,
-  ! otherwise it is not needed (since we have just fixed %sm in the
-  ! pre section). 
-  !
+    !
+    ! If POS was not specified and therefore we have amg_smooth_both_
+    ! we need to update sm2a *only* if it was already allocated,
+    ! otherwise it is not needed (since we have just fixed %sm in the
+    ! pre section). 
+    !
 
-  if ((ipos_ == amg_smooth_post_).or. &
-       ((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then 
+    if ((ipos_ == amg_smooth_post_).or. &
+         ((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then 
 
 
-    if (allocated(lev%sm2a)) then 
-      if (allocated(lev%sm2a%sv)) then
-        if (.not.same_type_as(lev%sm2a%sv,val))  then
-          call lev%sm2a%sv%free(info)
-          if (info == 0) deallocate(lev%sm2a%sv,stat=info)
+      if (allocated(lv%sm2a)) then 
+        if (allocated(lv%sm2a%sv)) then
+          if (.not.same_type_as(lv%sm2a%sv,val))  then
+            call lv%sm2a%sv%free(info)
+            if (info == 0) deallocate(lv%sm2a%sv,stat=info)
+            if (info /= 0) then
+              info = 3111
+              return
+            end if
+          end if
+        end if
+        if (.not.allocated(lv%sm2a%sv)) then 
+          allocate(lv%sm2a%sv,mold=val,stat=info) 
           if (info /= 0) then
             info = 3111
             return
           end if
         end if
-      end if
-      if (.not.allocated(lev%sm2a%sv)) then 
-        allocate(lev%sm2a%sv,mold=val,stat=info) 
-        if (info /= 0) then
-          info = 3111
-          return
-        end if
-      end if
-      call lev%sm2a%sv%default()
-      
-    else
-      info = 3111
-      write(psb_err_unit,*) name,&
-           &': Error: uninitialized preconditioner component,',&
-           &' should call amg_PRECINIT/amg_PRECSET' 
-      return 
-      
-    end if
-    
-  end if
-  
-end subroutine amg_d_base_onelev_setsv
+        call lv%sm2a%sv%default()
 
+      else
+        info = 3111
+        write(psb_err_unit,*) name,&
+             &': Error: uninitialized preconditioner component,',&
+             &' should call amg_PRECINIT/amg_PRECSET' 
+        return 
+
+      end if
+
+    end if
+
+  end subroutine amg_d_base_onelev_setsv
+
+end submodule amg_d_base_onelev_setsv_impl

amgprec/impl/level/amg_d_base_onelev_wrk_handle.f90

@@ -0,0 +1,333 @@
+!  
+!   
+!                             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 prior written permission.
+!   
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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.
+!   
+!  
+submodule (amg_d_onelev_mod)  amg_d_base_onelev_wrk_handle_impl
+  use psb_base_mod
+  
+contains
+  
+  module subroutine d_base_onelev_move_alloc(lv, b,info)
+    implicit none
+    class(amg_d_onelev_type), target, intent(inout) :: lv, b
+    integer(psb_ipk_), intent(out) :: info
+
+    call b%free(info)
+    b%parms  = lv%parms
+    b%szratio = lv%szratio
+    if (associated(lv%sm2,lv%sm2a)) then
+      call move_alloc(lv%sm,b%sm)
+      call move_alloc(lv%sm2a,b%sm2a)
+      b%sm2 =>b%sm2a
+    else
+      call move_alloc(lv%sm,b%sm)
+      call move_alloc(lv%sm2a,b%sm2a)
+      b%sm2 =>b%sm
+    end if
+
+    call move_alloc(lv%aggr,b%aggr)
+    if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
+    if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
+    if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
+    if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
+    if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
+    b%base_a    => lv%base_a
+    b%base_desc => lv%base_desc
+
+  end subroutine d_base_onelev_move_alloc
+
+  module subroutine d_base_onelev_allocate_wrk(lv,info,vmold)
+    implicit none
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    integer(psb_ipk_), intent(out) :: info
+    class(psb_d_base_vect_type), intent(in), optional  :: vmold
+    !
+    integer(psb_ipk_) :: nwv, i
+    info = psb_success_
+    nwv = lv%get_wrksz()
+    if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
+!!$    write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
+    if (info == 0) then
+      if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
+        !
+        !  Need to fix this, we need two different allocations
+        !
+        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
+             & desc2=lv%remap_data%desc_ac_pre_remap)
+      else
+        call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
+      end if
+    end if
+
+  end subroutine d_base_onelev_allocate_wrk
+
+  module subroutine d_base_onelev_free_wrk(lv,info)
+    implicit none
+    class(amg_d_onelev_type), target, intent(inout) :: lv
+    integer(psb_ipk_), intent(out) :: info
+    !
+    integer(psb_ipk_) :: nwv,i
+    info = psb_success_
+
+    if (allocated(lv%wrk)) then
+      call lv%wrk%free(info)
+      if (info == 0) deallocate(lv%wrk,stat=info)
+    end if
+  end subroutine d_base_onelev_free_wrk
+
+  module subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
+    Implicit None
+    ! Arguments
+    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+    integer(psb_ipk_), intent(in)                     :: nwv
+    type(psb_desc_type), intent(in)                   :: desc
+    integer(psb_ipk_), intent(out)                    :: info
+    class(psb_d_base_vect_type), intent(in), optional  :: vmold
+    type(psb_desc_type), intent(in), optional          :: desc2
+    !
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+    call wk%free(info)
+!!$    write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
+!!$         & present(desc2),desc%is_valid()
+
+    allocate(wk%wv(nwv),stat=info)    
+    if  (present(desc2).and.(desc%is_valid())) then
+!!$      write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
+      if (desc2%get_local_cols()>desc%get_local_cols()) then
+        call d_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
+      else
+        call d_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
+      end if
+    else if (present(desc2)) then
+      call d_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
+    else if (desc%is_valid()) then
+      call d_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)      
+    end if
+
+  contains
+  end subroutine d_wrk_alloc
+
+  module subroutine d_inner_do_wrk_alloc(wk,nwv,desc,vmold)
+    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+    integer(psb_ipk_), intent(in)                     :: nwv
+    type(psb_desc_type), intent(in)                   :: desc
+    class(psb_d_base_vect_type), intent(in), optional  :: vmold
+    
+    integer(psb_ipk_) :: i
+    
+    call psb_geasb(wk%vx2l,desc,info,&
+         & scratch=.true.,mold=vmold)
+    call psb_geasb(wk%vy2l,desc,info,&
+         & scratch=.true.,mold=vmold)
+    call psb_geasb(wk%vtx,desc,info,&
+         & scratch=.true.,mold=vmold)
+    call psb_geasb(wk%vty,desc,info,&
+         & scratch=.true.,mold=vmold)
+    do i=1,nwv
+      call psb_geasb(wk%wv(i),desc,info,&
+           & scratch=.true.,mold=vmold)
+    end do
+  end subroutine d_inner_do_wrk_alloc
+  
+  
+  module subroutine d_wrk_free(wk,info)
+
+    Implicit None
+
+    ! Arguments
+    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+    integer(psb_ipk_), intent(out)                    :: info
+    !
+    integer(psb_ipk_) :: i
+    info = psb_success_
+
+    if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
+    if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
+    if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
+    if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
+    call wk%vtx%free(info)
+    call wk%vty%free(info)
+    call wk%vx2l%free(info)
+    call wk%vy2l%free(info)
+    if (allocated(wk%wv)) then
+      do i=1,size(wk%wv)
+        call wk%wv(i)%free(info)
+      end do
+      deallocate(wk%wv, stat=info)
+    end if
+
+  end subroutine d_wrk_free
+
+  module subroutine d_wrk_clone(wk,wkout,info)
+    Implicit None
+
+    ! Arguments
+    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+    class(amg_dmlprec_wrk_type), target, intent(inout) :: wkout
+    integer(psb_ipk_), intent(out)                    :: info
+    !
+    integer(psb_ipk_) :: i
+    info = psb_success_
+
+    call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
+    call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
+    call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
+    call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
+    call wk%vtx%clone(wkout%vtx,info)
+    call wk%vty%clone(wkout%vty,info)
+    call wk%vx2l%clone(wkout%vx2l,info)
+    call wk%vy2l%clone(wkout%vy2l,info)
+    if (allocated(wkout%wv)) then
+      do i=1,size(wkout%wv)
+        call wkout%wv(i)%free(info)
+      end do
+      deallocate( wkout%wv)
+    end if
+    allocate(wkout%wv(size(wk%wv)),stat=info)
+    do i=1,size(wk%wv)
+      call wk%wv(i)%clone(wkout%wv(i),info)
+    end do
+    return
+
+  end subroutine d_wrk_clone
+
+  module subroutine d_wrk_move_alloc(wk, b,info)
+    implicit none
+    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk, b
+    integer(psb_ipk_), intent(out) :: info
+
+    call b%free(info)
+    call move_alloc(wk%tx,b%tx)
+    call move_alloc(wk%ty,b%ty)
+    call move_alloc(wk%x2l,b%x2l)
+    call move_alloc(wk%y2l,b%y2l)
+    !
+    ! Should define V%move_alloc....
+    call move_alloc(wk%vtx%v,b%vtx%v)
+    call move_alloc(wk%vty%v,b%vty%v)
+    call move_alloc(wk%vx2l%v,b%vx2l%v)
+    call move_alloc(wk%vy2l%v,b%vy2l%v)
+    call move_alloc(wk%wv,b%wv)
+
+  end subroutine d_wrk_move_alloc
+
+  module subroutine d_wrk_cnv(wk,info,vmold)
+    Implicit None
+
+    ! Arguments
+    class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
+    integer(psb_ipk_), intent(out)                    :: info
+    class(psb_d_base_vect_type), intent(in), optional  :: vmold
+    !
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+    if (present(vmold)) then
+      call wk%vtx%cnv(vmold)
+      call wk%vty%cnv(vmold)
+      call wk%vx2l%cnv(vmold)
+      call wk%vy2l%cnv(vmold)
+      if (allocated(wk%wv)) then
+        do i=1,size(wk%wv)
+          call wk%wv(i)%cnv(vmold)
+        end do
+      end if
+    end if
+  end subroutine d_wrk_cnv
+
+  module function d_wrk_sizeof(wk) result(val)
+    implicit none
+    class(amg_dmlprec_wrk_type), intent(in) :: wk
+    integer(psb_epk_) :: val
+    integer :: i
+    val = 0
+    val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%tx)
+    val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%ty)
+    val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%x2l)
+    val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%y2l)
+    val = val + wk%vtx%sizeof()
+    val = val + wk%vty%sizeof()
+    val = val + wk%vx2l%sizeof()
+    val = val + wk%vy2l%sizeof()
+    if (allocated(wk%wv)) then
+      do i=1, size(wk%wv)
+        val = val + wk%wv(i)%sizeof()
+      end do
+    end if
+  end function d_wrk_sizeof
+
+  module subroutine d_remap_data_clone(rmp, remap_out, info)
+    implicit none
+    ! Arguments
+    class(amg_d_remap_data_type), target, intent(inout) :: rmp
+    class(amg_d_remap_data_type), target, intent(inout) :: remap_out
+    integer(psb_ipk_), intent(out)                    :: info
+    !
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+
+    call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
+    if (info == psb_success_) &
+         & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
+    remap_out%idest = rmp%idest
+    call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
+    call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
+  end subroutine d_remap_data_clone
+
+  module subroutine d_remap_move_alloc(rmp, remap_out, info)
+    implicit none
+    ! Arguments
+    class(amg_d_remap_data_type), target, intent(inout) :: rmp
+    class(amg_d_remap_data_type), target, intent(inout) :: remap_out
+    integer(psb_ipk_), intent(out)                    :: info
+    !
+    integer(psb_ipk_) :: i
+
+    info = psb_success_
+
+    call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
+    if (info == psb_success_) &
+         & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
+    remap_out%idest = rmp%idest
+    call move_alloc(rmp%isrc,remap_out%isrc)
+    call move_alloc(rmp%nrsrc,remap_out%nrsrc)
+    call move_alloc(rmp%naggr,remap_out%naggr)
+  end subroutine d_remap_move_alloc
+  
+end submodule amg_d_base_onelev_wrk_handle_impl

amgprec/impl/level/amg_s_base_onelev_build.f90

@@ -35,129 +35,132 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+submodule (amg_s_onelev_mod)  amg_s_base_onelev_build_impl
   use psb_base_mod
-  use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_build
-  implicit none
-  class(amg_s_onelev_type), target, intent(inout) :: lv
-  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
-  integer(psb_ipk_), intent(in), optional :: ilv
-  ! Local
-  integer(psb_ipk_)   :: err,i,k, err_act
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: me, np
-  integer(psb_ipk_)   :: debug_level, debug_unit
-  character(len=20)   :: name, ch_err
+  
+contains
+  module  subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+    implicit none
+    class(amg_s_onelev_type), target, intent(inout) :: lv
+    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
+    integer(psb_ipk_), intent(in), optional :: ilv
+    ! Local
+    integer(psb_ipk_)   :: err,i,k, err_act
+    type(psb_ctxt_type) :: ctxt
+    integer(psb_ipk_)   :: me, np
+    integer(psb_ipk_)   :: debug_level, debug_unit
+    character(len=20)   :: name, ch_err
 
-  name = 'amg_onelev_build'
-  info=psb_success_
-  err=0
-  call psb_erractionsave(err_act)
-  if (psb_errstatus_fatal()) then
-    info = psb_err_internal_error_; goto 9999
-  end if
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  if (.not.associated(lv%base_desc)) then
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,&
-         & a_err='Unassociated base DESC')
-    goto 9999
-  end if
-  info = psb_success_
-  ctxt = lv%base_desc%get_ctxt()
-  call psb_info(ctxt,me,np)
-
-  !
-  ! At top level(s) I may be using
-  ! a context with less processes
-  !
-  if (me < 0) then
-!!$    write(0,*) 'onelevbld: I am excluded from this one '
-  else
-!!$    write(0,*) me,' Going to build smoothers at this level '
-    if (.not.allocated(lv%sm)) then 
-      !! Error: should have called amg_dprecinit
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
+    name = 'amg_onelev_build'
+    info=psb_success_
+    err=0
+    call psb_erractionsave(err_act)
+    if (psb_errstatus_fatal()) then
+      info = psb_err_internal_error_; goto 9999
     end if
-    if (.not.allocated(lv%sm%sv)) then 
-      !! Error: should have called amg_dprecinit
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-    lv%ac_nz_loc = lv%ac%get_nzeros()
-    lv%ac_nz_tot = lv%ac_nz_loc
-    select case(lv%parms%coarse_mat)
-    case(amg_distr_mat_) 
-      call psb_sum(ctxt,lv%ac_nz_tot)
-    case(amg_repl_mat_)
-      ! Do nothing
-    case default
-      ! Should never get here
-      info = psb_err_internal_error_
-      call psb_errpush(info,name,a_err='Wrong lv%parms')
-      goto 9999
-    end select
-    
-    
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Calling mlprcbld at level  ',i
-    call amg_check_def(lv%parms%sweeps_pre,&
-         & 'Jacobi sweeps',izero,is_int_non_negative)
-    call amg_check_def(lv%parms%sweeps_post,&
-         & 'Jacobi sweeps',izero,is_int_non_negative)
-    
-    call lv%sm%build(lv%base_a,lv%base_desc,info)
-    if (info == 0) then
-      if (allocated(lv%sm2a)) then 
-        call lv%sm2a%build(lv%base_a,lv%base_desc,info)
-        lv%sm2 => lv%sm2a
-      else
-        lv%sm2 => lv%sm
-      end if
-    end if
-    if (info /=0 ) then
+    debug_unit  = psb_get_debug_unit()
+    debug_level = psb_get_debug_level()
+    if (.not.associated(lv%base_desc)) then
       info = psb_err_internal_error_
       call psb_errpush(info,name,&
-           & a_err='Smoother bld error')
+           & a_err='Unassociated base DESC')
       goto 9999
     end if
-    
-    if (lv%sm%sv%is_global()) then
-      if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
-        lv%parms%sweeps_pre  = 1
-        lv%parms%sweeps_post = 1
-        if (me == 0) then
-          write(debug_unit,*) 
-          if (present(ilv)) then
-            write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
-                 & '" at level ',ilv
-            write(debug_unit,*) '         is configured as a global solver '
-          else
-            write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
-                 & '" is configured as a global solver '
+    info = psb_success_
+    ctxt = lv%base_desc%get_ctxt()
+    call psb_info(ctxt,me,np)
+
+    !
+    ! At top level(s) I may be using
+    ! a context with less processes
+    !
+    if (me < 0) then
+!!$    write(0,*) 'onelevbld: I am excluded from this one '
+    else
+!!$    write(0,*) me,' Going to build smoothers at this level '
+      if (.not.allocated(lv%sm)) then 
+        !! Error: should have called amg_dprecinit
+        info=3111
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+      if (.not.allocated(lv%sm%sv)) then 
+        !! Error: should have called amg_dprecinit
+        info=3111
+        call psb_errpush(info,name)
+        goto 9999
+      end if
+      lv%ac_nz_loc = lv%ac%get_nzeros()
+      lv%ac_nz_tot = lv%ac_nz_loc
+      select case(lv%parms%coarse_mat)
+      case(amg_distr_mat_) 
+        call psb_sum(ctxt,lv%ac_nz_tot)
+      case(amg_repl_mat_)
+        ! Do nothing
+      case default
+        ! Should never get here
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,a_err='Wrong lv%parms')
+        goto 9999
+      end select
+
+
+      if (debug_level >= psb_debug_outer_) &
+           & write(debug_unit,*) me,' ',trim(name),&
+           & 'Calling mlprcbld at level  ',i
+      call amg_check_def(lv%parms%sweeps_pre,&
+           & 'Jacobi sweeps',izero,is_int_non_negative)
+      call amg_check_def(lv%parms%sweeps_post,&
+           & 'Jacobi sweeps',izero,is_int_non_negative)
+
+      call lv%sm%build(lv%base_a,lv%base_desc,info)
+      if (info == 0) then
+        if (allocated(lv%sm2a)) then 
+          call lv%sm2a%build(lv%base_a,lv%base_desc,info)
+          lv%sm2 => lv%sm2a
+        else
+          lv%sm2 => lv%sm
+        end if
+      end if
+      if (info /=0 ) then
+        info = psb_err_internal_error_
+        call psb_errpush(info,name,&
+             & a_err='Smoother bld error')
+        goto 9999
+      end if
+
+      if (lv%sm%sv%is_global()) then
+        if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
+          lv%parms%sweeps_pre  = 1
+          lv%parms%sweeps_post = 1
+          if (me == 0) then
+            write(debug_unit,*) 
+            if (present(ilv)) then
+              write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
+                   & '" at level ',ilv
+              write(debug_unit,*) '         is configured as a global solver '
+            else
+              write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
+                   & '" is configured as a global solver '
+            end if
+            write(debug_unit,*) '        Pre and post sweeps at this level reset to 1'
           end if
-          write(debug_unit,*) '        Pre and post sweeps at this level reset to 1'
         end if
       end if
     end if
-  end if
-  
-  if (any((/present(amold),present(vmold),present(imold)/))) &
-       & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
 
-  call psb_erractionrestore(err_act)
-  return
+    if (any((/present(amold),present(vmold),present(imold)/))) &
+         & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
+
+    call psb_erractionrestore(err_act)
+    return
 
 9999 call psb_error_handler(err_act)
 
-  return
+    return
 
-end subroutine amg_s_base_onelev_build
+  end subroutine amg_s_base_onelev_build
+end submodule amg_s_base_onelev_build_impl

amgprec/impl/level/amg_s_base_onelev_check.f90

@@ -35,59 +35,60 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine amg_s_base_onelev_check(lv,info)
-  
+submodule (amg_s_onelev_mod)  amg_s_base_onelev_check_impl
   use psb_base_mod
-  use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_check
-
-  Implicit None
-
-  ! Arguments
-  class(amg_s_onelev_type), intent(inout) :: lv 
-  integer(psb_ipk_), intent(out)            :: info
-  integer(psb_ipk_)           :: err_act
-  character(len=20) :: name='s_base_onelev_check'
-
-  call psb_erractionsave(err_act)
-  info = psb_success_
-
-  call amg_check_def(lv%parms%sweeps_pre,&
-       & 'Jacobi sweeps',ione,is_int_non_negative)
-  call amg_check_def(lv%parms%sweeps_post,&
-       & 'Jacobi sweeps',ione,is_int_non_negative)
-
-  if (allocated(lv%sm)) then 
-    call lv%sm%check(info)
-  else 
-    info=3111
-    call psb_errpush(info,name)
-    goto 9999
-  end if
-
-  if (allocated(lv%sm2a)) then 
-    call lv%sm2a%check(info)
-  else if (.not.inner_check(lv%sm2,lv%sm)) then 
-    info=3111
-    call psb_errpush(info,name)
-    goto 9999
-  end if
-
-  if (info /= psb_success_) goto 9999
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-  return
 
 contains
-  function inner_check(smp,sm) result(res)
-    implicit none
-    logical :: res
-    class(amg_s_base_smoother_type), intent(in), pointer :: smp 
-    class(amg_s_base_smoother_type), intent(in), target  :: sm
+  module subroutine amg_s_base_onelev_check(lv,info)
+    Implicit None
 
-    res = associated(smp, sm)
-  end function inner_check
-  
-end subroutine amg_s_base_onelev_check
+    ! Arguments
+    class(amg_s_onelev_type), intent(inout) :: lv 
+    integer(psb_ipk_), intent(out)            :: info
+    integer(psb_ipk_)           :: err_act
+    character(len=20) :: name='s_base_onelev_check'
+
+    call psb_erractionsave(err_act)
+    info = psb_success_
+
+    call amg_check_def(lv%parms%sweeps_pre,&
+         & 'Jacobi sweeps',ione,is_int_non_negative)
+    call amg_check_def(lv%parms%sweeps_post,&
+         & 'Jacobi sweeps',ione,is_int_non_negative)
+
+    if (allocated(lv%sm)) then 
+      call lv%sm%check(info)
+    else 
+      info=3111
+      call psb_errpush(info,name)
+      goto 9999
+    end if
+
+    if (allocated(lv%sm2a)) then 
+      call lv%sm2a%check(info)
+    else if (.not.inner_check(lv%sm2,lv%sm)) then 
+      info=3111
+      call psb_errpush(info,name)
+      goto 9999
+    end if
+
+    if (info /= psb_success_) goto 9999
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+    return
+
+  contains
+    function inner_check(smp,sm) result(res)
+      implicit none
+      logical :: res
+      class(amg_s_base_smoother_type), intent(in), pointer :: smp 
+      class(amg_s_base_smoother_type), intent(in), target  :: sm
+
+      res = associated(smp, sm)
+    end function inner_check
+
+  end subroutine amg_s_base_onelev_check
+end submodule amg_s_base_onelev_check_impl