Added string trimming to improve passage of arguments from C interfaces

amgprec/CMakeLists.txt

@@ -509,6 +509,7 @@ 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
@@ -773,6 +774,7 @@ 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_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_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_base_smoother_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_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,7 +216,8 @@ 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_max_prec_ = 9
+  integer(psb_ipk_), parameter :: amg_richardson_ = 10
+  integer(psb_ipk_), parameter :: amg_max_prec_ = 10
   !
   ! Constants for pre/post signaling. Now only used internally
   !
@@ -229,7 +230,8 @@ module amg_base_prec_type
   !
   ! Legal values for entry: amg_sub_solve_
   !
-  integer(psb_ipk_), parameter :: amg_slv_delta_     = amg_max_prec_+1
+  ! Keep this fixed so sub-solver numeric IDs remain stable.
+  integer(psb_ipk_), parameter :: amg_slv_delta_     = 10
   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
@@ -409,7 +411,7 @@ module amg_base_prec_type
        & 'none          ','Jacobi        ',&
        & 'L1-Jacobi     ','none          ','none          ',&
        & 'none          ','none          ','L1-GS         ',&
-       & 'L1-FBGS       ','Polynomial    ','none          ','Point Jacobi  ',&
+      & 'L1-FBGS       ','Polynomial    ', 'Richards      ','Point Jacobi  ',&
        & 'L1-Jacobi     ','Gauss-Seidel  ','ILU(n)        ',&
        & 'MILU(n)       ','ILU(t,n)      ',&
        & 'SuperLU       ','UMFPACK LU    ',&
@@ -575,6 +577,8 @@ 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')
@@ -1202,6 +1206,8 @@ 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_linmap  => amg_c_base_aggregator_bld_linmap
+    procedure, pass(ag) :: bld_map     => amg_c_base_aggregator_bld_map
     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_linmap
+  !> Function   bld_map
   !! \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_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_c_base_aggregator_bld_map(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_linmap'
+    character(len=20) :: name='c_base_aggregator_bld_map'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -508,6 +508,7 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_c_base_aggregator_bld_linmap
+  end subroutine amg_c_base_aggregator_bld_map
+
 
 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_a(alpha,p,x,beta,y,desc_data,trans,work,info)
+    subroutine amg_cmlprec_aply(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_a
+    end subroutine amg_cmlprec_aply
     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,35 +154,13 @@ 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) :: move_alloc => c_remap_move_alloc
+    procedure, pass(rmp) :: clone   => c_remap_data_clone
   end type amg_c_remap_data_type
 
   type amg_c_onelev_type
@@ -228,7 +206,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
 
 
@@ -252,7 +230,9 @@ module amg_c_onelev_mod
        & c_base_onelev_free_wrk
 
   interface
-    module subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
+    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
       implicit none
       class(amg_c_onelev_type), intent(inout), target :: lv
       type(psb_cspmat_type), intent(in) :: a
@@ -264,7 +244,10 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+    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
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       integer(psb_ipk_), intent(out) :: info
@@ -276,7 +259,10 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
+    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
       Implicit None
       ! Arguments
       class(amg_c_onelev_type), intent(in)    :: lv
@@ -289,8 +275,10 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,&
-         & iout,verbosity, prefix,global) 
+    subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
+      import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
+           & psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
+           & psb_ipk_, psb_epk_, psb_desc_type
       Implicit None
       ! Arguments
       class(amg_c_onelev_type), intent(in)    :: lv
@@ -304,7 +292,10 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
+    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
       class(amg_c_onelev_type), intent(inout)            :: lv
       integer(psb_ipk_), intent(out)                     :: info
       class(psb_c_base_sparse_mat), intent(in), optional :: amold
@@ -314,32 +305,48 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_free(lv,info)
+    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
       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
-    module subroutine amg_c_base_onelev_free_smoothers(lv,info)
+    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
       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
-    module subroutine amg_c_base_onelev_check(lv,info)
+    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
       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
-    module subroutine amg_c_base_onelev_setsm(lv,val,info,pos)
+    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
       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
@@ -348,8 +355,12 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_setsv(lv,val,info,pos)
+    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
       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
@@ -358,8 +369,12 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_setag(lv,val,info,pos)
+    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
       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
@@ -368,8 +383,13 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
+    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
       Implicit None
+
+      ! Arguments
       class(amg_c_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       integer(psb_ipk_), intent(in)             :: val
@@ -380,8 +400,12 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
+    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
       Implicit None
+      ! Arguments
       class(amg_c_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       character(len=*), intent(in)              :: val
@@ -392,8 +416,12 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
+    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
       Implicit None
+
       class(amg_c_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       real(psb_spk_), intent(in)                 :: val
@@ -404,8 +432,11 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
+    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
@@ -416,7 +447,8 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+    subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+      import
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       complex(psb_spk_), intent(in)     :: alpha, beta
@@ -425,8 +457,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
-    module subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
-         & work,vtx,vty)
+    subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
+      import
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       complex(psb_spk_), intent(in)           :: alpha, beta
@@ -438,7 +470,8 @@ module amg_c_onelev_mod
   end interface
 
   interface
-    module subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+    subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+      import
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       complex(psb_spk_), intent(in)     :: alpha, beta
@@ -448,8 +481,8 @@ module amg_c_onelev_mod
       complex(psb_spk_), optional          :: work(:)
 
     end subroutine amg_c_base_onelev_map_prol_a
-    module subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
-         & work,vtx,vty)
+    subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
+      import
       implicit none
       class(amg_c_onelev_type), target, intent(inout) :: lv
       complex(psb_spk_), intent(in)           :: alpha, beta
@@ -460,118 +493,6 @@ 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
@@ -697,7 +618,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
@@ -739,6 +660,36 @@ 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
@@ -776,5 +727,269 @@ 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,7 +102,6 @@ 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
@@ -120,7 +119,6 @@ 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
@@ -437,19 +435,10 @@ 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
-    val = prec%nlevs
-!!$    write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv)
+    if (allocated(prec%precv)) then
+      val = size(prec%precv)
+    end if
   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.
@@ -520,7 +509,7 @@ contains
 
     real(psb_spk_) :: num, den, nmin
     type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: il,nl
+    integer(psb_ipk_)   :: il
 
     num = -sone
     den = sone
@@ -530,10 +519,7 @@ contains
       num = prec%precv(il)%base_a%get_nzeros()
       if (num >= szero) then
         den = num
-        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)
+        do il=2,size(prec%precv)
           num = num + max(0,prec%precv(il)%base_a%get_nzeros())
         end do
       end if
@@ -564,6 +550,7 @@ contains
   end function amg_c_get_avg_cr
 
   subroutine amg_c_cmp_avg_cr(prec)
+
     implicit none
     class(amg_cprec_type), intent(inout) :: prec
 
@@ -571,18 +558,17 @@ 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
@@ -600,7 +586,9 @@ contains
   !             error code.
   !
   subroutine amg_cprecfree(p,info)
+
     implicit none
+
     ! Arguments
     type(amg_cprec_type), intent(inout) :: p
     integer(psb_ipk_), intent(out)        :: info
@@ -626,7 +614,9 @@ 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
@@ -663,7 +653,9 @@ 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
@@ -680,7 +672,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      do i=1,prec%get_nlevs()
+      do i=1,size(prec%precv)
         call prec%precv(i)%free_smoothers(info)
       end do
     end if
@@ -694,7 +686,9 @@ 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
@@ -721,6 +715,7 @@ contains
 
   end subroutine amg_c_hierarchy_free
 
+
   !
   ! Top level methods.
   !
@@ -785,6 +780,7 @@ 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
@@ -849,6 +845,7 @@ 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
@@ -865,7 +862,7 @@ contains
     info = 0
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    iln = prec%get_nlevs()
+    iln = size(prec%precv)
     if (present(istart)) then
       il1 = max(1,istart)
     else
@@ -889,6 +886,7 @@ 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
@@ -900,7 +898,7 @@ contains
 
     info = psb_success_
     if (allocated(prec%precv)) then
-      do i=1,prec%get_nlevs()
+      do i=1,size(prec%precv)
         if (info == psb_success_ ) &
              & call prec%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
       end do
@@ -909,6 +907,7 @@ 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
@@ -920,6 +919,7 @@ 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,9 +935,8 @@ 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 = prec%get_nlevs()
+        ln = size(prec%precv)
         allocate(pout%precv(ln),stat=info)
         if (info /= psb_success_) goto 9999
         if (ln >= 1) then
@@ -945,7 +944,6 @@ 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
@@ -1025,7 +1023,7 @@ contains
     if (psb_errstatus_fatal()) then
       info = psb_err_internal_error_; goto 9999
     end if
-    nlev   = prec%get_nlevs()
+    nlev   = size(prec%precv)
     level = 1
     do level = 1, nlev
       call prec%precv(level)%allocate_wrk(info,vmold=vmold)
@@ -1048,6 +1046,7 @@ 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
@@ -1064,7 +1063,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      nlev   = prec%get_nlevs()
+      nlev   = size(prec%precv)
       do level = 1, nlev
         call prec%precv(level)%free_wrk(info)
       end do

amgprec/amg_config.h.in

@@ -17,6 +17,8 @@
 @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_linmap  => amg_d_base_aggregator_bld_linmap
+    procedure, pass(ag) :: bld_map     => amg_d_base_aggregator_bld_map
     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_linmap
+  !> Function   bld_map
   !! \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_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_d_base_aggregator_bld_map(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_linmap'
+    character(len=20) :: name='d_base_aggregator_bld_map'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -508,6 +508,7 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_d_base_aggregator_bld_linmap
+  end subroutine amg_d_base_aggregator_bld_map
+
 
 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_a(alpha,p,x,beta,y,desc_data,trans,work,info)
+    subroutine amg_dmlprec_aply(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_a
+    end subroutine amg_dmlprec_aply
     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(what))
+  select case(psb_toupper(trim(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(what))
+  select case(psb_toupper(trim(what)))
 #if defined(AMG_HAVE_MUMPS)
   case('MUMPS_RPAR_ENTRY')
     if(present(idx)) then 

amgprec/amg_d_onelev_mod.f90

@@ -155,35 +155,13 @@ 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) :: move_alloc => d_remap_move_alloc
+    procedure, pass(rmp) :: clone   => d_remap_data_clone
   end type amg_d_remap_data_type
 
   type amg_d_onelev_type
@@ -229,7 +207,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
 
 
@@ -253,7 +231,9 @@ module amg_d_onelev_mod
        & d_base_onelev_free_wrk
 
   interface
-    module subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
+    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
       implicit none
       class(amg_d_onelev_type), intent(inout), target :: lv
       type(psb_dspmat_type), intent(in) :: a
@@ -265,7 +245,10 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+    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
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       integer(psb_ipk_), intent(out) :: info
@@ -277,7 +260,10 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
+    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
       Implicit None
       ! Arguments
       class(amg_d_onelev_type), intent(in)    :: lv
@@ -290,8 +276,10 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,&
-         & iout,verbosity, prefix,global) 
+    subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
+           & psb_ipk_, psb_epk_, psb_desc_type
       Implicit None
       ! Arguments
       class(amg_d_onelev_type), intent(in)    :: lv
@@ -305,7 +293,10 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
+    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
       class(amg_d_onelev_type), intent(inout)            :: lv
       integer(psb_ipk_), intent(out)                     :: info
       class(psb_d_base_sparse_mat), intent(in), optional :: amold
@@ -315,32 +306,48 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_free(lv,info)
+    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
       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
-    module subroutine amg_d_base_onelev_free_smoothers(lv,info)
+    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
       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
-    module subroutine amg_d_base_onelev_check(lv,info)
+    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
       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
-    module subroutine amg_d_base_onelev_setsm(lv,val,info,pos)
+    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
       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
@@ -349,8 +356,12 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_setsv(lv,val,info,pos)
+    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
       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
@@ -359,8 +370,12 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_setag(lv,val,info,pos)
+    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
       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
@@ -369,8 +384,13 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
+    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
       Implicit None
+
+      ! Arguments
       class(amg_d_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       integer(psb_ipk_), intent(in)             :: val
@@ -381,8 +401,12 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
+    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
       Implicit None
+      ! Arguments
       class(amg_d_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       character(len=*), intent(in)              :: val
@@ -393,8 +417,12 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
+    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
       Implicit None
+
       class(amg_d_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       real(psb_dpk_), intent(in)                 :: val
@@ -405,8 +433,11 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
+    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
@@ -417,7 +448,8 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+    subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+      import
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       real(psb_dpk_), intent(in)     :: alpha, beta
@@ -426,8 +458,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
-    module subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
-         & work,vtx,vty)
+    subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
+      import
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       real(psb_dpk_), intent(in)           :: alpha, beta
@@ -439,7 +471,8 @@ module amg_d_onelev_mod
   end interface
 
   interface
-    module subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+    subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+      import
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       real(psb_dpk_), intent(in)     :: alpha, beta
@@ -449,8 +482,8 @@ module amg_d_onelev_mod
       real(psb_dpk_), optional          :: work(:)
 
     end subroutine amg_d_base_onelev_map_prol_a
-    module subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
-         & work,vtx,vty)
+    subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
+      import
       implicit none
       class(amg_d_onelev_type), target, intent(inout) :: lv
       real(psb_dpk_), intent(in)           :: alpha, beta
@@ -461,118 +494,6 @@ 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
@@ -698,7 +619,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
@@ -740,6 +661,36 @@ 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
@@ -777,5 +728,269 @@ 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_linmap   => amg_d_parmatch_aggregator_bld_linmap
+    procedure, pass(ag) :: bld_map      => amg_d_parmatch_aggregator_bld_map
     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_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_d_parmatch_aggregator_bld_map(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_linmap'
+    character(len=20) :: name='d_parmatch_aggregator_bld_map'
 
     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_linmap
+  end subroutine amg_d_parmatch_aggregator_bld_map
 end module amg_d_parmatch_aggregator_mod

amgprec/amg_d_prec_type.f90

@@ -102,7 +102,6 @@ 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
@@ -120,7 +119,6 @@ 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
@@ -437,19 +435,10 @@ 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
-    val = prec%nlevs
-!!$    write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv)
+    if (allocated(prec%precv)) then
+      val = size(prec%precv)
+    end if
   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.
@@ -520,7 +509,7 @@ contains
 
     real(psb_dpk_) :: num, den, nmin
     type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: il,nl
+    integer(psb_ipk_)   :: il
 
     num = -done
     den = done
@@ -530,10 +519,7 @@ contains
       num = prec%precv(il)%base_a%get_nzeros()
       if (num >= dzero) then
         den = num
-        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)
+        do il=2,size(prec%precv)
           num = num + max(0,prec%precv(il)%base_a%get_nzeros())
         end do
       end if
@@ -564,6 +550,7 @@ contains
   end function amg_d_get_avg_cr
 
   subroutine amg_d_cmp_avg_cr(prec)
+
     implicit none
     class(amg_dprec_type), intent(inout) :: prec
 
@@ -571,18 +558,17 @@ 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
@@ -600,7 +586,9 @@ contains
   !             error code.
   !
   subroutine amg_dprecfree(p,info)
+
     implicit none
+
     ! Arguments
     type(amg_dprec_type), intent(inout) :: p
     integer(psb_ipk_), intent(out)        :: info
@@ -626,7 +614,9 @@ 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
@@ -663,7 +653,9 @@ 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
@@ -680,7 +672,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      do i=1,prec%get_nlevs()
+      do i=1,size(prec%precv)
         call prec%precv(i)%free_smoothers(info)
       end do
     end if
@@ -694,7 +686,9 @@ 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
@@ -721,6 +715,7 @@ contains
 
   end subroutine amg_d_hierarchy_free
 
+
   !
   ! Top level methods.
   !
@@ -785,6 +780,7 @@ 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
@@ -849,6 +845,7 @@ 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
@@ -865,7 +862,7 @@ contains
     info = 0
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    iln = prec%get_nlevs()
+    iln = size(prec%precv)
     if (present(istart)) then
       il1 = max(1,istart)
     else
@@ -889,6 +886,7 @@ 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
@@ -900,7 +898,7 @@ contains
 
     info = psb_success_
     if (allocated(prec%precv)) then
-      do i=1,prec%get_nlevs()
+      do i=1,size(prec%precv)
         if (info == psb_success_ ) &
              & call prec%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
       end do
@@ -909,6 +907,7 @@ 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
@@ -920,6 +919,7 @@ 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,9 +935,8 @@ 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 = prec%get_nlevs()
+        ln = size(prec%precv)
         allocate(pout%precv(ln),stat=info)
         if (info /= psb_success_) goto 9999
         if (ln >= 1) then
@@ -945,7 +944,6 @@ 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
@@ -1025,7 +1023,7 @@ contains
     if (psb_errstatus_fatal()) then
       info = psb_err_internal_error_; goto 9999
     end if
-    nlev   = prec%get_nlevs()
+    nlev   = size(prec%precv)
     level = 1
     do level = 1, nlev
       call prec%precv(level)%allocate_wrk(info,vmold=vmold)
@@ -1048,6 +1046,7 @@ 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
@@ -1064,7 +1063,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      nlev   = prec%get_nlevs()
+      nlev   = size(prec%precv)
       do level = 1, nlev
         call prec%precv(level)%free_wrk(info)
       end do

amgprec/amg_d_richards_smoother.f90

@@ -0,0 +1,365 @@
+!
+!
+!                             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_linmap  => amg_s_base_aggregator_bld_linmap
+    procedure, pass(ag) :: bld_map     => amg_s_base_aggregator_bld_map
     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_linmap
+  !> Function   bld_map
   !! \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_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_s_base_aggregator_bld_map(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_linmap'
+    character(len=20) :: name='s_base_aggregator_bld_map'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -508,6 +508,7 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_s_base_aggregator_bld_linmap
+  end subroutine amg_s_base_aggregator_bld_map
+
 
 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_a(alpha,p,x,beta,y,desc_data,trans,work,info)
+    subroutine amg_smlprec_aply(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_a
+    end subroutine amg_smlprec_aply
     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,35 +155,13 @@ 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) :: move_alloc => s_remap_move_alloc
+    procedure, pass(rmp) :: clone   => s_remap_data_clone
   end type amg_s_remap_data_type
 
   type amg_s_onelev_type
@@ -229,7 +207,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
 
 
@@ -253,7 +231,9 @@ module amg_s_onelev_mod
        & s_base_onelev_free_wrk
 
   interface
-    module subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
+    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
       implicit none
       class(amg_s_onelev_type), intent(inout), target :: lv
       type(psb_sspmat_type), intent(in) :: a
@@ -265,7 +245,10 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+    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
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       integer(psb_ipk_), intent(out) :: info
@@ -277,7 +260,10 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
+    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
       Implicit None
       ! Arguments
       class(amg_s_onelev_type), intent(in)    :: lv
@@ -290,8 +276,10 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,&
-         & iout,verbosity, prefix,global) 
+    subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
+           & psb_ipk_, psb_epk_, psb_desc_type
       Implicit None
       ! Arguments
       class(amg_s_onelev_type), intent(in)    :: lv
@@ -305,7 +293,10 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
+    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
       class(amg_s_onelev_type), intent(inout)            :: lv
       integer(psb_ipk_), intent(out)                     :: info
       class(psb_s_base_sparse_mat), intent(in), optional :: amold
@@ -315,32 +306,48 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_free(lv,info)
+    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
       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
-    module subroutine amg_s_base_onelev_free_smoothers(lv,info)
+    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
       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
-    module subroutine amg_s_base_onelev_check(lv,info)
+    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
       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
-    module subroutine amg_s_base_onelev_setsm(lv,val,info,pos)
+    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
       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
@@ -349,8 +356,12 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_setsv(lv,val,info,pos)
+    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
       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
@@ -359,8 +370,12 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_setag(lv,val,info,pos)
+    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
       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
@@ -369,8 +384,13 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx)
+    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
       Implicit None
+
+      ! Arguments
       class(amg_s_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       integer(psb_ipk_), intent(in)             :: val
@@ -381,8 +401,12 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
+    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
       Implicit None
+      ! Arguments
       class(amg_s_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       character(len=*), intent(in)              :: val
@@ -393,8 +417,12 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx)
+    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
       Implicit None
+
       class(amg_s_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       real(psb_spk_), intent(in)                 :: val
@@ -405,8 +433,11 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
+    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
@@ -417,7 +448,8 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+    subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+      import
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       real(psb_spk_), intent(in)     :: alpha, beta
@@ -426,8 +458,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
-    module subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
-         & work,vtx,vty)
+    subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
+      import
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       real(psb_spk_), intent(in)           :: alpha, beta
@@ -439,7 +471,8 @@ module amg_s_onelev_mod
   end interface
 
   interface
-    module subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+    subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+      import
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       real(psb_spk_), intent(in)     :: alpha, beta
@@ -449,8 +482,8 @@ module amg_s_onelev_mod
       real(psb_spk_), optional          :: work(:)
 
     end subroutine amg_s_base_onelev_map_prol_a
-    module subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
-         & work,vtx,vty)
+    subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
+      import
       implicit none
       class(amg_s_onelev_type), target, intent(inout) :: lv
       real(psb_spk_), intent(in)           :: alpha, beta
@@ -461,118 +494,6 @@ 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
@@ -698,7 +619,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
@@ -740,6 +661,36 @@ 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
@@ -777,5 +728,269 @@ 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_linmap   => amg_s_parmatch_aggregator_bld_linmap
+    procedure, pass(ag) :: bld_map      => amg_s_parmatch_aggregator_bld_map
     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_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_s_parmatch_aggregator_bld_map(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_linmap'
+    character(len=20) :: name='s_parmatch_aggregator_bld_map'
 
     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_linmap
+  end subroutine amg_s_parmatch_aggregator_bld_map
 end module amg_s_parmatch_aggregator_mod

amgprec/amg_s_prec_type.f90

@@ -102,7 +102,6 @@ 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
@@ -120,7 +119,6 @@ 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
@@ -437,19 +435,10 @@ 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
-    val = prec%nlevs
-!!$    write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv)
+    if (allocated(prec%precv)) then
+      val = size(prec%precv)
+    end if
   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.
@@ -520,7 +509,7 @@ contains
 
     real(psb_spk_) :: num, den, nmin
     type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: il,nl
+    integer(psb_ipk_)   :: il
 
     num = -sone
     den = sone
@@ -530,10 +519,7 @@ contains
       num = prec%precv(il)%base_a%get_nzeros()
       if (num >= szero) then
         den = num
-        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)
+        do il=2,size(prec%precv)
           num = num + max(0,prec%precv(il)%base_a%get_nzeros())
         end do
       end if
@@ -564,6 +550,7 @@ contains
   end function amg_s_get_avg_cr
 
   subroutine amg_s_cmp_avg_cr(prec)
+
     implicit none
     class(amg_sprec_type), intent(inout) :: prec
 
@@ -571,18 +558,17 @@ 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
@@ -600,7 +586,9 @@ contains
   !             error code.
   !
   subroutine amg_sprecfree(p,info)
+
     implicit none
+
     ! Arguments
     type(amg_sprec_type), intent(inout) :: p
     integer(psb_ipk_), intent(out)        :: info
@@ -626,7 +614,9 @@ 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
@@ -663,7 +653,9 @@ 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
@@ -680,7 +672,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      do i=1,prec%get_nlevs()
+      do i=1,size(prec%precv)
         call prec%precv(i)%free_smoothers(info)
       end do
     end if
@@ -694,7 +686,9 @@ 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
@@ -721,6 +715,7 @@ contains
 
   end subroutine amg_s_hierarchy_free
 
+
   !
   ! Top level methods.
   !
@@ -785,6 +780,7 @@ 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
@@ -849,6 +845,7 @@ 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
@@ -865,7 +862,7 @@ contains
     info = 0
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    iln = prec%get_nlevs()
+    iln = size(prec%precv)
     if (present(istart)) then
       il1 = max(1,istart)
     else
@@ -889,6 +886,7 @@ 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
@@ -900,7 +898,7 @@ contains
 
     info = psb_success_
     if (allocated(prec%precv)) then
-      do i=1,prec%get_nlevs()
+      do i=1,size(prec%precv)
         if (info == psb_success_ ) &
              & call prec%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
       end do
@@ -909,6 +907,7 @@ 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
@@ -920,6 +919,7 @@ 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,9 +935,8 @@ 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 = prec%get_nlevs()
+        ln = size(prec%precv)
         allocate(pout%precv(ln),stat=info)
         if (info /= psb_success_) goto 9999
         if (ln >= 1) then
@@ -945,7 +944,6 @@ 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
@@ -1025,7 +1023,7 @@ contains
     if (psb_errstatus_fatal()) then
       info = psb_err_internal_error_; goto 9999
     end if
-    nlev   = prec%get_nlevs()
+    nlev   = size(prec%precv)
     level = 1
     do level = 1, nlev
       call prec%precv(level)%allocate_wrk(info,vmold=vmold)
@@ -1048,6 +1046,7 @@ 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
@@ -1064,7 +1063,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      nlev   = prec%get_nlevs()
+      nlev   = size(prec%precv)
       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_linmap  => amg_z_base_aggregator_bld_linmap
+    procedure, pass(ag) :: bld_map     => amg_z_base_aggregator_bld_map
     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_linmap
+  !> Function   bld_map
   !! \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_linmap(ag,desc_a,desc_ac,ilaggr,nlaggr,&
+  subroutine  amg_z_base_aggregator_bld_map(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_linmap'
+    character(len=20) :: name='z_base_aggregator_bld_map'
 
     info = psb_success_
     call psb_erractionsave(err_act)
@@ -508,6 +508,7 @@ contains
 9999 call psb_error_handler(err_act)
 
     return
-  end subroutine amg_z_base_aggregator_bld_linmap
+  end subroutine amg_z_base_aggregator_bld_map
+
 
 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_a(alpha,p,x,beta,y,desc_data,trans,work,info)
+    subroutine amg_zmlprec_aply(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_a
+    end subroutine amg_zmlprec_aply
     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,35 +154,13 @@ 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) :: move_alloc => z_remap_move_alloc
+    procedure, pass(rmp) :: clone   => z_remap_data_clone
   end type amg_z_remap_data_type
 
   type amg_z_onelev_type
@@ -228,7 +206,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
 
 
@@ -252,7 +230,9 @@ module amg_z_onelev_mod
        & z_base_onelev_free_wrk
 
   interface
-    module subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
+    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
       implicit none
       class(amg_z_onelev_type), intent(inout), target :: lv
       type(psb_zspmat_type), intent(in) :: a
@@ -264,7 +244,10 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv)
+    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
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       integer(psb_ipk_), intent(out) :: info
@@ -276,7 +259,10 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
+    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
       Implicit None
       ! Arguments
       class(amg_z_onelev_type), intent(in)    :: lv
@@ -289,8 +275,10 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,&
-         & iout,verbosity, prefix,global) 
+    subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
+      import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
+           & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
+           & psb_ipk_, psb_epk_, psb_desc_type
       Implicit None
       ! Arguments
       class(amg_z_onelev_type), intent(in)    :: lv
@@ -304,7 +292,10 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
+    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
       class(amg_z_onelev_type), intent(inout)            :: lv
       integer(psb_ipk_), intent(out)                     :: info
       class(psb_z_base_sparse_mat), intent(in), optional :: amold
@@ -314,32 +305,48 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_free(lv,info)
+    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
       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
-    module subroutine amg_z_base_onelev_free_smoothers(lv,info)
+    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
       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
-    module subroutine amg_z_base_onelev_check(lv,info)
+    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
       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
-    module subroutine amg_z_base_onelev_setsm(lv,val,info,pos)
+    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
       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
@@ -348,8 +355,12 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_setsv(lv,val,info,pos)
+    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
       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
@@ -358,8 +369,12 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_setag(lv,val,info,pos)
+    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
       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
@@ -368,8 +383,13 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx)
+    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
       Implicit None
+
+      ! Arguments
       class(amg_z_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       integer(psb_ipk_), intent(in)             :: val
@@ -380,8 +400,12 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
+    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
       Implicit None
+      ! Arguments
       class(amg_z_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       character(len=*), intent(in)              :: val
@@ -392,8 +416,12 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx)
+    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
       Implicit None
+
       class(amg_z_onelev_type), intent(inout) :: lv
       character(len=*), intent(in)              :: what
       real(psb_dpk_), intent(in)                 :: val
@@ -404,8 +432,11 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
+    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
@@ -416,7 +447,8 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+    subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
+      import
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       complex(psb_dpk_), intent(in)     :: alpha, beta
@@ -425,8 +457,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
-    module subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
-         & work,vtx,vty)
+    subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
+      import
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       complex(psb_dpk_), intent(in)           :: alpha, beta
@@ -438,7 +470,8 @@ module amg_z_onelev_mod
   end interface
 
   interface
-    module subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+    subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
+      import
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       complex(psb_dpk_), intent(in)     :: alpha, beta
@@ -448,8 +481,8 @@ module amg_z_onelev_mod
       complex(psb_dpk_), optional          :: work(:)
 
     end subroutine amg_z_base_onelev_map_prol_a
-    module subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
-         & work,vtx,vty)
+    subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
+      import
       implicit none
       class(amg_z_onelev_type), target, intent(inout) :: lv
       complex(psb_dpk_), intent(in)           :: alpha, beta
@@ -460,118 +493,6 @@ 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
@@ -697,7 +618,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
@@ -739,6 +660,36 @@ 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
@@ -776,5 +727,269 @@ 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,7 +102,6 @@ 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
@@ -120,7 +119,6 @@ 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
@@ -437,19 +435,10 @@ 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
-    val = prec%nlevs
-!!$    write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv)
+    if (allocated(prec%precv)) then
+      val = size(prec%precv)
+    end if
   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.
@@ -520,7 +509,7 @@ contains
 
     real(psb_dpk_) :: num, den, nmin
     type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: il,nl
+    integer(psb_ipk_)   :: il
 
     num = -done
     den = done
@@ -530,10 +519,7 @@ contains
       num = prec%precv(il)%base_a%get_nzeros()
       if (num >= dzero) then
         den = num
-        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)
+        do il=2,size(prec%precv)
           num = num + max(0,prec%precv(il)%base_a%get_nzeros())
         end do
       end if
@@ -564,6 +550,7 @@ contains
   end function amg_z_get_avg_cr
 
   subroutine amg_z_cmp_avg_cr(prec)
+
     implicit none
     class(amg_zprec_type), intent(inout) :: prec
 
@@ -571,18 +558,17 @@ 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
@@ -600,7 +586,9 @@ contains
   !             error code.
   !
   subroutine amg_zprecfree(p,info)
+
     implicit none
+
     ! Arguments
     type(amg_zprec_type), intent(inout) :: p
     integer(psb_ipk_), intent(out)        :: info
@@ -626,7 +614,9 @@ 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
@@ -663,7 +653,9 @@ 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
@@ -680,7 +672,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      do i=1,prec%get_nlevs()
+      do i=1,size(prec%precv)
         call prec%precv(i)%free_smoothers(info)
       end do
     end if
@@ -694,7 +686,9 @@ 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
@@ -721,6 +715,7 @@ contains
 
   end subroutine amg_z_hierarchy_free
 
+
   !
   ! Top level methods.
   !
@@ -785,6 +780,7 @@ 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
@@ -849,6 +845,7 @@ 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
@@ -865,7 +862,7 @@ contains
     info = 0
     ctxt = prec%ctxt
     call psb_info(ctxt,iam,np)
-    iln = prec%get_nlevs()
+    iln = size(prec%precv)
     if (present(istart)) then
       il1 = max(1,istart)
     else
@@ -889,6 +886,7 @@ 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
@@ -900,7 +898,7 @@ contains
 
     info = psb_success_
     if (allocated(prec%precv)) then
-      do i=1,prec%get_nlevs()
+      do i=1,size(prec%precv)
         if (info == psb_success_ ) &
              & call prec%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold)
       end do
@@ -909,6 +907,7 @@ 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
@@ -920,6 +919,7 @@ 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,9 +935,8 @@ 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 = prec%get_nlevs()
+        ln = size(prec%precv)
         allocate(pout%precv(ln),stat=info)
         if (info /= psb_success_) goto 9999
         if (ln >= 1) then
@@ -945,7 +944,6 @@ 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
@@ -1025,7 +1023,7 @@ contains
     if (psb_errstatus_fatal()) then
       info = psb_err_internal_error_; goto 9999
     end if
-    nlev   = prec%get_nlevs()
+    nlev   = size(prec%precv)
     level = 1
     do level = 1, nlev
       call prec%precv(level)%allocate_wrk(info,vmold=vmold)
@@ -1048,6 +1046,7 @@ 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
@@ -1064,7 +1063,7 @@ contains
     end if
 
     if (allocated(prec%precv)) then
-      nlev   = prec%get_nlevs()
+      nlev   = size(prec%precv)
       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_a.o \
+	amg_dmlprec_aply.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_a.o \
+	amg_smlprec_aply.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_a.o \
+	amg_zmlprec_aply.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_a.o \
+	amg_cmlprec_aply.o   \
 	$(CMPFOBJS)  amg_c_extprol_bld.o
 
 INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS)

amgprec/impl/aggregator/amg_c_dec_aggregator_mat_asb.f90

@@ -114,67 +114,63 @@ 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)
 
-    case(amg_distr_mat_) 
+  select case(parms%coarse_mat)
 
-      call ac%cscnv(info,type='csr')
-      call op_prol%cscnv(info,type='csr')
-      call op_restr%cscnv(info,type='csr')
+  case(amg_distr_mat_) 
 
-      if (debug_level >= psb_debug_outer_) &
-           & write(debug_unit,*) me,' ',trim(name),&
-           & 'Done ac '
+    call ac%cscnv(info,type='csr')
+    call op_prol%cscnv(info,type='csr')
+    call op_restr%cscnv(info,type='csr')
 
-    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
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'Done ac '
 
-      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 
+  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 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 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
+
+
   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,46 +169,39 @@ 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)
 
-  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_) 
+  !
+  ! 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_) 
 
-    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)
 
-      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
+  case default
+    info = psb_err_internal_error_
+    call psb_errpush(info,name,a_err='Invalid aggr kind')
+    goto 9999
 
+  end select
   if (info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld')
     goto 9999
@@ -221,5 +214,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,23 +122,19 @@ 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)
 
-    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
+  !
+  ! The decoupled aggregator based on SOC measures ignores
+  ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
+  !
+  if (do_timings) call psb_tic(idx_map_bld)
+  clean_zeros = ag%do_clean_zeros
+  call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+  if (do_timings) call psb_toc(idx_map_bld)
+  if (do_timings) call psb_tic(idx_map_tprol)
+
+  if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+  if (do_timings) call psb_toc(idx_map_tprol)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_d_dec_aggregator_mat_asb.f90

@@ -114,67 +114,63 @@ 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)
 
-    case(amg_distr_mat_) 
+  select case(parms%coarse_mat)
 
-      call ac%cscnv(info,type='csr')
-      call op_prol%cscnv(info,type='csr')
-      call op_restr%cscnv(info,type='csr')
+  case(amg_distr_mat_) 
 
-      if (debug_level >= psb_debug_outer_) &
-           & write(debug_unit,*) me,' ',trim(name),&
-           & 'Done ac '
+    call ac%cscnv(info,type='csr')
+    call op_prol%cscnv(info,type='csr')
+    call op_restr%cscnv(info,type='csr')
 
-    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
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'Done ac '
 
-      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 
+  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 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 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
+
+
   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,46 +169,39 @@ 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)
 
-  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_) 
+  !
+  ! 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_) 
 
-    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)
 
-      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
+  case default
+    info = psb_err_internal_error_
+    call psb_errpush(info,name,a_err='Invalid aggr kind')
+    goto 9999
 
+  end select
   if (info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld')
     goto 9999
@@ -221,5 +214,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,23 +122,19 @@ 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)
 
-    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
+  !
+  ! The decoupled aggregator based on SOC measures ignores
+  ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
+  !
+  if (do_timings) call psb_tic(idx_map_bld)
+  clean_zeros = ag%do_clean_zeros
+  call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+  if (do_timings) call psb_toc(idx_map_bld)
+  if (do_timings) call psb_tic(idx_map_tprol)
+
+  if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+  if (do_timings) call psb_toc(idx_map_tprol)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_s_dec_aggregator_mat_asb.f90

@@ -114,67 +114,63 @@ 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)
 
-    case(amg_distr_mat_) 
+  select case(parms%coarse_mat)
 
-      call ac%cscnv(info,type='csr')
-      call op_prol%cscnv(info,type='csr')
-      call op_restr%cscnv(info,type='csr')
+  case(amg_distr_mat_) 
 
-      if (debug_level >= psb_debug_outer_) &
-           & write(debug_unit,*) me,' ',trim(name),&
-           & 'Done ac '
+    call ac%cscnv(info,type='csr')
+    call op_prol%cscnv(info,type='csr')
+    call op_restr%cscnv(info,type='csr')
 
-    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
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'Done ac '
 
-      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 
+  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 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 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
+
+
   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,46 +169,39 @@ 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)
 
-  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_) 
+  !
+  ! 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_) 
 
-    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)
 
-      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
+  case default
+    info = psb_err_internal_error_
+    call psb_errpush(info,name,a_err='Invalid aggr kind')
+    goto 9999
 
+  end select
   if (info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld')
     goto 9999
@@ -221,5 +214,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,23 +122,19 @@ 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)
 
-    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
+  !
+  ! The decoupled aggregator based on SOC measures ignores
+  ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
+  !
+  if (do_timings) call psb_tic(idx_map_bld)
+  clean_zeros = ag%do_clean_zeros
+  call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+  if (do_timings) call psb_toc(idx_map_bld)
+  if (do_timings) call psb_tic(idx_map_tprol)
+
+  if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+  if (do_timings) call psb_toc(idx_map_tprol)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/aggregator/amg_z_dec_aggregator_mat_asb.f90

@@ -114,67 +114,63 @@ 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)
 
-    case(amg_distr_mat_) 
+  select case(parms%coarse_mat)
 
-      call ac%cscnv(info,type='csr')
-      call op_prol%cscnv(info,type='csr')
-      call op_restr%cscnv(info,type='csr')
+  case(amg_distr_mat_) 
 
-      if (debug_level >= psb_debug_outer_) &
-           & write(debug_unit,*) me,' ',trim(name),&
-           & 'Done ac '
+    call ac%cscnv(info,type='csr')
+    call op_prol%cscnv(info,type='csr')
+    call op_restr%cscnv(info,type='csr')
 
-    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
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'Done ac '
 
-      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 
+  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 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 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
+
+
   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,46 +169,39 @@ 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)
 
-  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_) 
+  !
+  ! 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_) 
 
-    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)
 
-      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
+  case default
+    info = psb_err_internal_error_
+    call psb_errpush(info,name,a_err='Invalid aggr kind')
+    goto 9999
 
+  end select
   if (info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld')
     goto 9999
@@ -221,5 +214,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,23 +122,19 @@ 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)
 
-    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
+  !
+  ! The decoupled aggregator based on SOC measures ignores
+  ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
+  !
+  if (do_timings) call psb_tic(idx_map_bld)
+  clean_zeros = ag%do_clean_zeros
+  call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
+  if (do_timings) call psb_toc(idx_map_bld)
+  if (do_timings) call psb_tic(idx_map_tprol)
+
+  if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
+  if (do_timings) call psb_toc(idx_map_tprol)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

amgprec/impl/amg_c_hierarchy_bld.F90

@@ -64,9 +64,11 @@
 !               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
@@ -80,7 +82,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, level
+       & nplevs, mxplevs
   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, &
@@ -96,9 +98,6 @@ 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
@@ -131,7 +130,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 
   !   
@@ -140,7 +139,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       = prec%get_nlevs()
+  iszv       = size(prec%precv)
   call psb_bcast(ctxt,iszv)
   call psb_bcast(ctxt,mncsize)
   call psb_bcast(ctxt,mncszpp)
@@ -166,7 +165,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 /= prec%get_nlevs()) then 
+  if (iszv /= size(prec%precv)) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999
@@ -181,7 +180,6 @@ 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
@@ -229,6 +227,7 @@ 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)
 
   !
@@ -241,7 +240,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   end if
   !
-  ! First set desired number of levels if different from default. 
+  ! First set desired number of levels
   !
   if (iszv /= nplevs) then
     allocate(tprecv(nplevs),stat=info)
@@ -287,8 +286,7 @@ 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)
-    call prec%set_nlevs(nplevs)
-    iszv = prec%get_nlevs()
+    iszv = size(prec%precv)
   end if
 
   !
@@ -303,24 +301,15 @@ 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
     !
@@ -336,8 +325,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 tentative mapping between levels i-1 and i
-    ! and the matrix at level i
+    ! Build the 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_)&
@@ -359,26 +348,47 @@ 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. 
-    !
-    if (i == 2) then 
-      call amg_c_hierarchy_bld_cmp_newsz(i,iszv,&
-           & desc_a%get_global_rows(),&
-           & nlaggr,casize,mnaggratio,sizeratio,newsz)
+    !      
+    iaggsize = sum(nlaggr)
+
+    sizeratio = iaggsize
+    if (i==2) then 
+      sizeratio = desc_a%get_global_rows()/sizeratio
     else
-      call amg_c_hierarchy_bld_cmp_newsz(i,iszv,&
-           & sum(prec%precv(i-1)%linmap%naggr),&
-           & nlaggr,casize,mnaggratio,sizeratio,newsz)
+      sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
     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
@@ -412,102 +422,92 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
              & a_err=ch_err)
         goto 9999
       endif
-!!$      write(0,*) ' Early exit  of array_build_loop',i,iszv,info,&
-      level = newsz
-      stop_hierarchy_loop = .true. 
+      exit array_build_loop
     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 (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
+    if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
+
   end do array_build_loop
 
-!!$  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
+  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
   end if
-  iszv = prec%get_nlevs()
-  call psb_barrier(ctxt)
 
 
-!!$  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)
+  !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
 
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
@@ -515,9 +515,8 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   endif
 
-  iszv = prec%get_nlevs()
-!!$  write(0,*) 'Going for cmp_complexity ',&
-!!$       & allocated(prec%precv),iszv,size(prec%precv)
+  iszv = size(prec%precv)
+
   call prec%cmp_complexity()
   call prec%cmp_avg_cr()
 
@@ -657,49 +656,4 @@ 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       = prec%get_nlevs()
+  iszv       = size(prec%precv)
   call psb_bcast(ctxt,iszv)
-  if (iszv /= prec%get_nlevs()) then
+  if (iszv /= size(prec%precv)) 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 = prec%get_nlevs()
+        nlev = size(prec%precv)
         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,7 +207,6 @@ 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
@@ -244,10 +243,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  ', p%get_nlevs()
+       & ' Entry  ', size(p%precv)
 
   trans_ = psb_toupper(trans)
-  nlev   = p%get_nlevs()
+  nlev   = size(p%precv)
 
   do_alloc_wrk = .not.allocated(p%precv(1)%wrk)
 
@@ -382,7 +381,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -394,38 +393,39 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
     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
+    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
     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 = p%get_nlevs()
+    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')
@@ -492,13 +492,12 @@ 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,&
@@ -510,6 +509,7 @@ 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,37 +523,40 @@ 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))
+             & info,work=work,&
+             & vtx=wv(1),vty=p%precv(level+1)%wrk%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, vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),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
     
@@ -594,7 +597,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -605,7 +608,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'))
@@ -615,10 +618,6 @@ 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
@@ -626,6 +625,7 @@ 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,29 +644,28 @@ contains
                    & a_err='Error during PRE smoother_apply')
               goto 9999
             end if
-      
-          endif
+          end if
+        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))
+               & info,work=work,&
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -676,7 +675,8 @@ 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))
+               & info,work=work,&
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -691,7 +691,8 @@ contains
         !  
         call p%precv(level+1)%map_prol(cone,&
              & p%precv(level+1)%wrk%vy2l,cone,vy2l,&
-             & info,work=work,vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
@@ -700,17 +701,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))
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during W-cycle restriction')
@@ -721,7 +722,8 @@ contains
 
           if (info == psb_success_) call p%precv(level+1)%map_prol(cone, &
                & p%precv(level+1)%wrk%vy2l,cone,vy2l,&
-               & info,work=work,vty=wv(1))
+               & info,work=work,&
+               & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -733,7 +735,7 @@ contains
 
 
         if (post) then
-          
+          if (me >=0) then 
             call psb_geaxpby(cone,vx2l,&
                  & czero,vty,&
                  & base_desc,info)
@@ -760,7 +762,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,&
@@ -787,7 +789,6 @@ contains
              & a_err='Invalid LEVEL vs NLEV')
         goto 9999
       end if
-    end if
     end associate
 9998 continue
     call psb_erractionrestore(err_act)
@@ -832,7 +833,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -909,7 +910,7 @@ contains
         call  p%precv(level + 1)%map_rstr(cone,vty,&
              & czero,p%precv(level + 1)%wrk%vx2l,&
              &info,work=work,&
-             & vtx=wv(1))
+             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -944,7 +945,8 @@ contains
         !  
         call p%precv(level+1)%map_prol(cone,&
              & p%precv(level+1)%wrk%vy2l,cone,vy2l,&
-             & info,work=work,vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -1005,6 +1007,9 @@ 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
 
@@ -1156,3 +1161,532 @@ 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

@@ -1,733 +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   
-!        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,7 +214,9 @@ 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)
@@ -226,8 +228,6 @@ 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,6 +241,7 @@ 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,9 +64,11 @@
 !               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
@@ -80,7 +82,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, level
+       & nplevs, mxplevs
   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, &
@@ -96,9 +98,6 @@ 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
@@ -131,7 +130,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 
   !   
@@ -140,7 +139,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       = prec%get_nlevs()
+  iszv       = size(prec%precv)
   call psb_bcast(ctxt,iszv)
   call psb_bcast(ctxt,mncsize)
   call psb_bcast(ctxt,mncszpp)
@@ -166,7 +165,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 /= prec%get_nlevs()) then 
+  if (iszv /= size(prec%precv)) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999
@@ -181,7 +180,6 @@ 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
@@ -229,6 +227,7 @@ 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)
 
   !
@@ -241,7 +240,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   end if
   !
-  ! First set desired number of levels if different from default. 
+  ! First set desired number of levels
   !
   if (iszv /= nplevs) then
     allocate(tprecv(nplevs),stat=info)
@@ -287,8 +286,7 @@ 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)
-    call prec%set_nlevs(nplevs)
-    iszv = prec%get_nlevs()
+    iszv = size(prec%precv)
   end if
 
   !
@@ -303,24 +301,15 @@ 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
     !
@@ -336,8 +325,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 tentative mapping between levels i-1 and i
-    ! and the matrix at level i
+    ! Build the 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_)&
@@ -359,26 +348,47 @@ 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. 
-    !
-    if (i == 2) then 
-      call amg_d_hierarchy_bld_cmp_newsz(i,iszv,&
-           & desc_a%get_global_rows(),&
-           & nlaggr,casize,mnaggratio,sizeratio,newsz)
+    !      
+    iaggsize = sum(nlaggr)
+
+    sizeratio = iaggsize
+    if (i==2) then 
+      sizeratio = desc_a%get_global_rows()/sizeratio
     else
-      call amg_d_hierarchy_bld_cmp_newsz(i,iszv,&
-           & sum(prec%precv(i-1)%linmap%naggr),&
-           & nlaggr,casize,mnaggratio,sizeratio,newsz)
+      sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
     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
@@ -412,102 +422,92 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
              & a_err=ch_err)
         goto 9999
       endif
-!!$      write(0,*) ' Early exit  of array_build_loop',i,iszv,info,&
-      level = newsz
-      stop_hierarchy_loop = .true. 
+      exit array_build_loop
     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 (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
+    if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
+
   end do array_build_loop
 
-!!$  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
+  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
   end if
-  iszv = prec%get_nlevs()
-  call psb_barrier(ctxt)
 
 
-!!$  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)
+  !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
 
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
@@ -515,9 +515,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   endif
 
-  iszv = prec%get_nlevs()
-!!$  write(0,*) 'Going for cmp_complexity ',&
-!!$       & allocated(prec%precv),iszv,size(prec%precv)
+  iszv = size(prec%precv)
+
   call prec%cmp_complexity()
   call prec%cmp_avg_cr()
 
@@ -657,49 +656,4 @@ 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       = prec%get_nlevs()
+  iszv       = size(prec%precv)
   call psb_bcast(ctxt,iszv)
-  if (iszv /= prec%get_nlevs()) then
+  if (iszv /= size(prec%precv)) 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 = prec%get_nlevs()
+        nlev = size(prec%precv)
         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,7 +207,6 @@ 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
@@ -244,10 +243,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  ', p%get_nlevs()
+       & ' Entry  ', size(p%precv)
 
   trans_ = psb_toupper(trans)
-  nlev   = p%get_nlevs()
+  nlev   = size(p%precv)
 
   do_alloc_wrk = .not.allocated(p%precv(1)%wrk)
 
@@ -382,7 +381,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -394,38 +393,39 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
     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
+    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
     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 = p%get_nlevs()
+    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')
@@ -492,13 +492,12 @@ 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,&
@@ -510,6 +509,7 @@ 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,37 +523,40 @@ 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))
+             & info,work=work,&
+             & vtx=wv(1),vty=p%precv(level+1)%wrk%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, vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),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
     
@@ -594,7 +597,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -605,7 +608,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'))
@@ -615,10 +618,6 @@ 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
@@ -626,6 +625,7 @@ 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,29 +644,28 @@ contains
                    & a_err='Error during PRE smoother_apply')
               goto 9999
             end if
-      
-          endif
+          end if
+        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))
+               & info,work=work,&
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -676,7 +675,8 @@ 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))
+               & info,work=work,&
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -691,7 +691,8 @@ contains
         !  
         call p%precv(level+1)%map_prol(done,&
              & p%precv(level+1)%wrk%vy2l,done,vy2l,&
-             & info,work=work,vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
@@ -700,17 +701,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))
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during W-cycle restriction')
@@ -721,7 +722,8 @@ contains
 
           if (info == psb_success_) call p%precv(level+1)%map_prol(done, &
                & p%precv(level+1)%wrk%vy2l,done,vy2l,&
-               & info,work=work,vty=wv(1))
+               & info,work=work,&
+               & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -733,7 +735,7 @@ contains
 
 
         if (post) then
-          
+          if (me >=0) then 
             call psb_geaxpby(done,vx2l,&
                  & dzero,vty,&
                  & base_desc,info)
@@ -760,7 +762,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,&
@@ -787,7 +789,6 @@ contains
              & a_err='Invalid LEVEL vs NLEV')
         goto 9999
       end if
-    end if
     end associate
 9998 continue
     call psb_erractionrestore(err_act)
@@ -832,7 +833,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -909,7 +910,7 @@ contains
         call  p%precv(level + 1)%map_rstr(done,vty,&
              & dzero,p%precv(level + 1)%wrk%vx2l,&
              &info,work=work,&
-             & vtx=wv(1))
+             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -944,7 +945,8 @@ contains
         !  
         call p%precv(level+1)%map_prol(done,&
              & p%precv(level+1)%wrk%vy2l,done,vy2l,&
-             & info,work=work,vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -1005,6 +1007,9 @@ 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
 
@@ -1156,3 +1161,532 @@ 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

@@ -1,733 +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   
-!        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,7 +226,9 @@ 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)
@@ -238,8 +240,6 @@ 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,6 +255,7 @@ 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,9 +64,11 @@
 !               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
@@ -80,7 +82,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, level
+       & nplevs, mxplevs
   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, &
@@ -96,9 +98,6 @@ 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
@@ -131,7 +130,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 
   !   
@@ -140,7 +139,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       = prec%get_nlevs()
+  iszv       = size(prec%precv)
   call psb_bcast(ctxt,iszv)
   call psb_bcast(ctxt,mncsize)
   call psb_bcast(ctxt,mncszpp)
@@ -166,7 +165,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 /= prec%get_nlevs()) then 
+  if (iszv /= size(prec%precv)) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999
@@ -181,7 +180,6 @@ 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
@@ -229,6 +227,7 @@ 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)
 
   !
@@ -241,7 +240,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   end if
   !
-  ! First set desired number of levels if different from default. 
+  ! First set desired number of levels
   !
   if (iszv /= nplevs) then
     allocate(tprecv(nplevs),stat=info)
@@ -287,8 +286,7 @@ 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)
-    call prec%set_nlevs(nplevs)
-    iszv = prec%get_nlevs()
+    iszv = size(prec%precv)
   end if
 
   !
@@ -303,24 +301,15 @@ 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
     !
@@ -336,8 +325,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 tentative mapping between levels i-1 and i
-    ! and the matrix at level i
+    ! Build the 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_)&
@@ -359,26 +348,47 @@ 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. 
-    !
-    if (i == 2) then 
-      call amg_s_hierarchy_bld_cmp_newsz(i,iszv,&
-           & desc_a%get_global_rows(),&
-           & nlaggr,casize,mnaggratio,sizeratio,newsz)
+    !      
+    iaggsize = sum(nlaggr)
+
+    sizeratio = iaggsize
+    if (i==2) then 
+      sizeratio = desc_a%get_global_rows()/sizeratio
     else
-      call amg_s_hierarchy_bld_cmp_newsz(i,iszv,&
-           & sum(prec%precv(i-1)%linmap%naggr),&
-           & nlaggr,casize,mnaggratio,sizeratio,newsz)
+      sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
     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
@@ -412,102 +422,92 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
              & a_err=ch_err)
         goto 9999
       endif
-!!$      write(0,*) ' Early exit  of array_build_loop',i,iszv,info,&
-      level = newsz
-      stop_hierarchy_loop = .true. 
+      exit array_build_loop
     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 (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
+    if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
+
   end do array_build_loop
 
-!!$  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
+  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
   end if
-  iszv = prec%get_nlevs()
-  call psb_barrier(ctxt)
 
 
-!!$  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)
+  !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
 
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
@@ -515,9 +515,8 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   endif
 
-  iszv = prec%get_nlevs()
-!!$  write(0,*) 'Going for cmp_complexity ',&
-!!$       & allocated(prec%precv),iszv,size(prec%precv)
+  iszv = size(prec%precv)
+
   call prec%cmp_complexity()
   call prec%cmp_avg_cr()
 
@@ -657,49 +656,4 @@ 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       = prec%get_nlevs()
+  iszv       = size(prec%precv)
   call psb_bcast(ctxt,iszv)
-  if (iszv /= prec%get_nlevs()) then
+  if (iszv /= size(prec%precv)) 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 = prec%get_nlevs()
+        nlev = size(prec%precv)
         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,7 +207,6 @@ 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
@@ -244,10 +243,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  ', p%get_nlevs()
+       & ' Entry  ', size(p%precv)
 
   trans_ = psb_toupper(trans)
-  nlev   = p%get_nlevs()
+  nlev   = size(p%precv)
 
   do_alloc_wrk = .not.allocated(p%precv(1)%wrk)
 
@@ -382,7 +381,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -394,38 +393,39 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
     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
+    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
     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 = p%get_nlevs()
+    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')
@@ -492,13 +492,12 @@ 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,&
@@ -510,6 +509,7 @@ 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,37 +523,40 @@ 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))
+             & info,work=work,&
+             & vtx=wv(1),vty=p%precv(level+1)%wrk%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, vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),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
     
@@ -594,7 +597,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -605,7 +608,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'))
@@ -615,10 +618,6 @@ 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
@@ -626,6 +625,7 @@ 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,29 +644,28 @@ contains
                    & a_err='Error during PRE smoother_apply')
               goto 9999
             end if
-      
-          endif
+          end if
+        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))
+               & info,work=work,&
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -676,7 +675,8 @@ 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))
+               & info,work=work,&
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -691,7 +691,8 @@ contains
         !  
         call p%precv(level+1)%map_prol(sone,&
              & p%precv(level+1)%wrk%vy2l,sone,vy2l,&
-             & info,work=work,vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
@@ -700,17 +701,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))
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during W-cycle restriction')
@@ -721,7 +722,8 @@ contains
 
           if (info == psb_success_) call p%precv(level+1)%map_prol(sone, &
                & p%precv(level+1)%wrk%vy2l,sone,vy2l,&
-               & info,work=work,vty=wv(1))
+               & info,work=work,&
+               & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -733,7 +735,7 @@ contains
 
 
         if (post) then
-          
+          if (me >=0) then 
             call psb_geaxpby(sone,vx2l,&
                  & szero,vty,&
                  & base_desc,info)
@@ -760,7 +762,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,&
@@ -787,7 +789,6 @@ contains
              & a_err='Invalid LEVEL vs NLEV')
         goto 9999
       end if
-    end if
     end associate
 9998 continue
     call psb_erractionrestore(err_act)
@@ -832,7 +833,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -909,7 +910,7 @@ contains
         call  p%precv(level + 1)%map_rstr(sone,vty,&
              & szero,p%precv(level + 1)%wrk%vx2l,&
              &info,work=work,&
-             & vtx=wv(1))
+             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -944,7 +945,8 @@ contains
         !  
         call p%precv(level+1)%map_prol(sone,&
              & p%precv(level+1)%wrk%vy2l,sone,vy2l,&
-             & info,work=work,vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -1005,6 +1007,9 @@ 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
 
@@ -1156,3 +1161,532 @@ 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

@@ -1,733 +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   
-!        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,7 +223,9 @@ 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)
@@ -235,8 +237,6 @@ 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,6 +250,7 @@ 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,9 +64,11 @@
 !               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
@@ -80,7 +82,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, level
+       & nplevs, mxplevs
   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, &
@@ -96,9 +98,6 @@ 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
@@ -131,7 +130,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 
   !   
@@ -140,7 +139,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       = prec%get_nlevs()
+  iszv       = size(prec%precv)
   call psb_bcast(ctxt,iszv)
   call psb_bcast(ctxt,mncsize)
   call psb_bcast(ctxt,mncszpp)
@@ -166,7 +165,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 /= prec%get_nlevs()) then 
+  if (iszv /= size(prec%precv)) then 
     info=psb_err_internal_error_
     call psb_errpush(info,name,a_err='Inconsistent size of precv')
     goto 9999
@@ -181,7 +180,6 @@ 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
@@ -229,6 +227,7 @@ 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)
 
   !
@@ -241,7 +240,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   end if
   !
-  ! First set desired number of levels if different from default. 
+  ! First set desired number of levels
   !
   if (iszv /= nplevs) then
     allocate(tprecv(nplevs),stat=info)
@@ -287,8 +286,7 @@ 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)
-    call prec%set_nlevs(nplevs)
-    iszv = prec%get_nlevs()
+    iszv = size(prec%precv)
   end if
 
   !
@@ -303,24 +301,15 @@ 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
     !
@@ -336,8 +325,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 tentative mapping between levels i-1 and i
-    ! and the matrix at level i
+    ! Build the 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_)&
@@ -359,26 +348,47 @@ 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. 
-    !
-    if (i == 2) then 
-      call amg_z_hierarchy_bld_cmp_newsz(i,iszv,&
-           & desc_a%get_global_rows(),&
-           & nlaggr,casize,mnaggratio,sizeratio,newsz)
+    !      
+    iaggsize = sum(nlaggr)
+
+    sizeratio = iaggsize
+    if (i==2) then 
+      sizeratio = desc_a%get_global_rows()/sizeratio
     else
-      call amg_z_hierarchy_bld_cmp_newsz(i,iszv,&
-           & sum(prec%precv(i-1)%linmap%naggr),&
-           & nlaggr,casize,mnaggratio,sizeratio,newsz)
+      sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
     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
@@ -412,102 +422,92 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
              & a_err=ch_err)
         goto 9999
       endif
-!!$      write(0,*) ' Early exit  of array_build_loop',i,iszv,info,&
-      level = newsz
-      stop_hierarchy_loop = .true. 
+      exit array_build_loop
     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 (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
+    if (i<iszv) call prec%precv(i)%update_aggr(prec%precv(i+1),info)
+
   end do array_build_loop
 
-!!$  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
+  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
   end if
-  iszv = prec%get_nlevs()
-  call psb_barrier(ctxt)
 
 
-!!$  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)
+  !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
 
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
@@ -515,9 +515,8 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat)
     goto 9999
   endif
 
-  iszv = prec%get_nlevs()
-!!$  write(0,*) 'Going for cmp_complexity ',&
-!!$       & allocated(prec%precv),iszv,size(prec%precv)
+  iszv = size(prec%precv)
+
   call prec%cmp_complexity()
   call prec%cmp_avg_cr()
 
@@ -657,49 +656,4 @@ 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       = prec%get_nlevs()
+  iszv       = size(prec%precv)
   call psb_bcast(ctxt,iszv)
-  if (iszv /= prec%get_nlevs()) then
+  if (iszv /= size(prec%precv)) 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 = prec%get_nlevs()
+        nlev = size(prec%precv)
         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,7 +207,6 @@ 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
@@ -244,10 +243,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  ', p%get_nlevs()
+       & ' Entry  ', size(p%precv)
 
   trans_ = psb_toupper(trans)
-  nlev   = p%get_nlevs()
+  nlev   = size(p%precv)
 
   do_alloc_wrk = .not.allocated(p%precv(1)%wrk)
 
@@ -382,7 +381,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -394,38 +393,39 @@ contains
     if(debug_level > 1) then
       write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
     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
+    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
     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 = p%get_nlevs()
+    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')
@@ -492,13 +492,12 @@ 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,&
@@ -510,6 +509,7 @@ 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,37 +523,40 @@ 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))
+             & info,work=work,&
+             & vtx=wv(1),vty=p%precv(level+1)%wrk%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, vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),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
     
@@ -594,7 +597,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -605,7 +608,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'))
@@ -615,10 +618,6 @@ 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
@@ -626,6 +625,7 @@ 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,29 +644,28 @@ contains
                    & a_err='Error during PRE smoother_apply')
               goto 9999
             end if
-      
-          endif
+          end if
+        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))
+               & info,work=work,&
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -676,7 +675,8 @@ 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))
+               & info,work=work,&
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during restriction')
@@ -691,7 +691,8 @@ contains
         !  
         call p%precv(level+1)%map_prol(zone,&
              & p%precv(level+1)%wrk%vy2l,zone,vy2l,&
-             & info,work=work,vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
                & a_err='Error during prolongation')
@@ -700,17 +701,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))
+               & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
                  & a_err='Error during W-cycle restriction')
@@ -721,7 +722,8 @@ contains
 
           if (info == psb_success_) call p%precv(level+1)%map_prol(zone, &
                & p%precv(level+1)%wrk%vy2l,zone,vy2l,&
-               & info,work=work,vty=wv(1))
+               & info,work=work,&
+               & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
 
           if (info /= psb_success_) then
             call psb_errpush(psb_err_internal_error_,name,&
@@ -733,7 +735,7 @@ contains
 
 
         if (post) then
-          
+          if (me >=0) then 
             call psb_geaxpby(zone,vx2l,&
                  & zzero,vty,&
                  & base_desc,info)
@@ -760,7 +762,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,&
@@ -787,7 +789,6 @@ contains
              & a_err='Invalid LEVEL vs NLEV')
         goto 9999
       end if
-    end if
     end associate
 9998 continue
     call psb_erractionrestore(err_act)
@@ -832,7 +833,7 @@ contains
     call psb_erractionsave(err_act)
     debug_unit  = psb_get_debug_unit()
     debug_level = psb_get_debug_level()
-    nlev = p%get_nlevs()
+    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')
@@ -909,7 +910,7 @@ contains
         call  p%precv(level + 1)%map_rstr(zone,vty,&
              & zzero,p%precv(level + 1)%wrk%vx2l,&
              &info,work=work,&
-             & vtx=wv(1))
+             & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -944,7 +945,8 @@ contains
         !  
         call p%precv(level+1)%map_prol(zone,&
              & p%precv(level+1)%wrk%vy2l,zone,vy2l,&
-             & info,work=work,vty=wv(1))
+             & info,work=work,&
+             & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
 
         if (info /= psb_success_) then
           call psb_errpush(psb_err_internal_error_,name,&
@@ -1005,6 +1007,9 @@ 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
 
@@ -1156,3 +1161,532 @@ 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

@@ -1,733 +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   
-!        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,7 +217,9 @@ 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)
@@ -229,8 +231,6 @@ 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,6 +246,7 @@ 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,12 +75,7 @@ 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_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 
-
+amg_z_base_onelev_map_prol.o 
 
 
 LIBNAME=libamg_prec.a
@@ -94,4 +89,4 @@ veryclean: clean
 	/bin/rm -f $(LIBNAME)
 
 clean:
-	/bin/rm -f $(OBJS) $(LOCAL_MODS) *.smod
+	/bin/rm -f $(OBJS) $(LOCAL_MODS)

amgprec/impl/level/amg_c_base_onelev_build.f90

@@ -35,132 +35,129 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_build_impl
+subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
   use psb_base_mod
-  
-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
+  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
 
-    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')
+  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
     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
+    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
-      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
+    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
       end if
     end if
+  end if
+  
+  if (any((/present(amold),present(vmold),present(imold)/))) &
+       & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
 
-    if (any((/present(amold),present(vmold),present(imold)/))) &
-         & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
-
-    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_build
-end submodule amg_c_base_onelev_build_impl
+end subroutine amg_c_base_onelev_build

amgprec/impl/level/amg_c_base_onelev_check.f90

@@ -35,60 +35,59 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_check_impl
+subroutine amg_c_base_onelev_check(lv,info)
+  
   use psb_base_mod
+  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_check
 
-contains
-  module subroutine amg_c_base_onelev_check(lv,info)
-    Implicit None
+  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'
+  ! 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 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)
+  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%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 (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
+  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
 
-  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
+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
+    res = associated(smp, sm)
+  end function inner_check
+  
+end subroutine amg_c_base_onelev_check

amgprec/impl/level/amg_c_base_onelev_cnv.f90

@@ -35,36 +35,33 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_cnv_impl
-  use psb_base_mod
+subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
   
-contains
-  module subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
+  use psb_base_mod
+  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_cnv
+  implicit none 
 
-    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
 
-    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
 
-    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
+  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

amgprec/impl/level/amg_c_base_onelev_csetc.F90

@@ -35,281 +35,277 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !
 !
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_csetc_impl
+subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
+
   use psb_base_mod
-  
-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
+  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
 #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
-        ipos_ = amg_smooth_both_
-      end select
-    else
+  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 if
+    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)
+  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 ('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 ('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 ('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 ('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 ('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
-
-
-    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)
-#endif
-#ifdef AMG_HAVE_MUMPS 
-      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 ('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?')
-          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
-      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 ('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
-      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)
+      !
+      ! 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)
+#endif
+#ifdef AMG_HAVE_MUMPS 
+    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 ('ML_CYCLE')
+    lv%parms%ml_cycle      = amg_stringval(val)
 
-    if (info /= psb_success_) goto 9999
+  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
 
-    call psb_erractionrestore(err_act)
-    return
+    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
+
+  call psb_erractionrestore(err_act)
+  return
 
 9999 call psb_error_handler(err_act)
-    return
+  return
 
-  end subroutine amg_c_base_onelev_csetc
-end submodule amg_c_base_onelev_csetc_impl
+end subroutine amg_c_base_onelev_csetc

amgprec/impl/level/amg_c_base_onelev_cseti.F90

@@ -35,238 +35,234 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !
 !
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_cseti_impl
+subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
+
   use psb_base_mod
-  
-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
+  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
 #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
-        ipos_ = amg_smooth_both_
-      end select
-    else
+  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 if
+    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)
+  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_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_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_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_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_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
-
-
-    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)
-#endif
-#ifdef AMG_HAVE_MUMPS
-      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 (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
-      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)
-
+      !
+      ! Do nothing and hope for the best :)
+      !
     end select
-    if (info /= psb_success_) goto 9999
-    call psb_erractionrestore(err_act)
-    return
+    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)
+#endif
+#ifdef AMG_HAVE_MUMPS
+    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
+    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
 
 9999 call psb_error_handler(err_act)
-    return
+  return
 
-  end subroutine amg_c_base_onelev_cseti
-end submodule amg_c_base_onelev_cseti_impl
+end subroutine amg_c_base_onelev_cseti

amgprec/impl/level/amg_c_base_onelev_csetr.f90

@@ -35,73 +35,71 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_csetr_impl
-  use psb_base_mod
+subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
   
-contains
-  module subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
+  use psb_base_mod
+  use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_csetr
 
-    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
-          ipos_ = amg_smooth_both_
-        end select
-      else
+  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 if
+      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
+    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
-      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 ((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
-      if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
+    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 submodule amg_c_base_onelev_csetr_impl
+end subroutine amg_c_base_onelev_csetr

amgprec/impl/level/amg_c_base_onelev_descr.f90

@@ -42,116 +42,108 @@
 !         0: normal
 !        >1: increased details 
 !
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_descr_impl
-  use psb_base_mod
+subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
   
-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
+  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_
-    type(psb_ctxt_type) :: pctxt
-    integer(psb_ipk_)   :: pme, pnp
+  ! 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)
+  call psb_erractionsave(err_act)
 
 
-    coarse = (il==nl)
+  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(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
 
-    pctxt = lv%desc_ac%get_ctxt()
-    call psb_info(pctxt,pme,pnp) 
-    write(iout_,*) trim(prefix_)
-    write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
-    write(iout_,*) trim(prefix_)
-    if (il == ilmin) then 
-      call lv%parms%mlcycledsc(iout_,info)
+  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
-    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_)
+    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
     end if
 
-    if (il > 1) then 
+    call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
 
-      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
+    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
-
-      if (coarse.and.allocated(lv%sm)) &
-           & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
     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 submodule amg_c_base_onelev_descr_impl
+end subroutine amg_c_base_onelev_descr

amgprec/impl/level/amg_c_base_onelev_dump.f90

@@ -35,137 +35,135 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_dump_impl
+subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
+     & smoother,solver,tprol,global_num)
+
   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
   
-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"
+  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 (associated(lv%base_desc)) then 
-      ctxt = lv%base_desc%get_context()
-      call psb_info(ctxt,iam,np)
-    else 
-      iam     = -1
-      np      = -1
+    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
-    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
+  end if
+  
+end subroutine amg_c_base_onelev_dump

amgprec/impl/level/amg_c_base_onelev_free.f90

@@ -35,43 +35,41 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_free_impl
-  use psb_base_mod
+subroutine amg_c_base_onelev_free(lv,info)
   
-contains
-  module subroutine amg_c_base_onelev_free(lv,info)
-    implicit none 
+  use psb_base_mod
+  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_free
+  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 submodule amg_c_base_onelev_free_impl
+end subroutine amg_c_base_onelev_free

amgprec/impl/level/amg_c_base_onelev_free_smoothers.f90

@@ -35,28 +35,26 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_dree_smoothers_impl
-  use psb_base_mod
+subroutine amg_c_base_onelev_free_smoothers(lv,info)
   
-contains
-  module subroutine amg_c_base_onelev_free_smoothers(lv,info)
-    implicit none 
+  use psb_base_mod
+  use amg_c_onelev_mod, amg_protect_name =>  amg_c_base_onelev_free_smoothers
+  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 submodule amg_c_base_onelev_dree_smoothers_impl
+end subroutine amg_c_base_onelev_free_smoothers

amgprec/impl/level/amg_c_base_onelev_map_prol.F90

@@ -35,113 +35,101 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_map_prol_impl
+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
   
-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
-      !
+  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
+    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)
+      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,mold=vect_u%v) 
+        
+        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
 !!$        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 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
+        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
 !!$      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 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 subroutine amg_c_base_onelev_map_prol_v
+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(:)
 
-  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
+  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

amgprec/impl/level/amg_c_base_onelev_map_rstr.F90

@@ -36,115 +36,94 @@
 !   
 !  
 
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_map_rstr_impl
+subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
+     &  work,vtx,vty)
   use psb_base_mod
-  
-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
+  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
 
 !!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-    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
-      !
+  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, 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)
+    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)
 !!$        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,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)))
+        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)))
 !!$          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,' 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
+          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
 
-    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
+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(:)
 
-  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
+  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

amgprec/impl/level/amg_c_base_onelev_mat_asb.f90

@@ -83,111 +83,109 @@
 !    info    -  integer, output.
 !               Error code.         
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_mat_asb_impl
+subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
+
   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)
 
-    implicit none
+  ! 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.
 
-    ! 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
+  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)
 
 
-    ! 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.
+  !
+  ! 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
 
-    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")
+  !
+  ! 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
 
-    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
+  call psb_erractionrestore(err_act)
+  return
 
 9999 call psb_error_handler(err_act)
-    return
+  return
 
-  end subroutine amg_c_base_onelev_mat_asb
-end submodule amg_c_base_onelev_mat_asb_impl
+end subroutine amg_c_base_onelev_mat_asb

amgprec/impl/level/amg_c_base_onelev_memory_use.f90

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

amgprec/impl/level/amg_c_base_onelev_setag.f90

@@ -35,50 +35,48 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_setag_impl
+subroutine amg_c_base_onelev_setag(lv,val,info,pos)
+
   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
   
-contains
-  module subroutine amg_c_base_onelev_setag(lv,val,info,pos)
+  ! Local variables
+  integer(psb_ipk_)                :: ipos_
+  character(len=*), parameter      :: name='amg_base_onelev_setag'
 
-    implicit none
+  info = psb_success_
 
-    ! 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) 
+  ! 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
-      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,73 +35,72 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_setsm_impl
+subroutine amg_c_base_onelev_setsm(lev,val,info,pos)
+
   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
   
-contains
-  module subroutine amg_c_base_onelev_setsm(lv,val,info,pos)
-    implicit none
+  ! Local variables
+  integer(psb_ipk_)                      :: ipos_
+  character(len=*), parameter            :: name='amg_base_onelev_setsm'
+  
+  info = psb_success_
 
-    ! 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
+  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 if
-
-    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
-    end if
-
-    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
+  else
+    ipos_ = amg_smooth_both_
+  end if
 
-  end subroutine amg_c_base_onelev_setsm
+  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)
+      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
 
-end submodule amg_c_base_onelev_setsm_impl

amgprec/impl/level/amg_c_base_onelev_setsv.F90

@@ -35,111 +35,110 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_c_onelev_mod)  amg_c_base_onelev_setsv_impl
+subroutine amg_c_base_onelev_setsv(lev,val,info,pos)
+
   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
   
-contains
-  module subroutine amg_c_base_onelev_setsv(lv,val,info,pos)
-    implicit none
+  ! Local variables
+  integer(psb_ipk_)                :: ipos_
+  character(len=*), parameter      :: name='amg_base_onelev_setsv'
 
-    ! 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
+  info = psb_success_
 
-    ! 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
+  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 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) 
+    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)
           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
-    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 ((ipos_ == amg_smooth_post_).or. &
-         ((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then 
-
-
-      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
+      
+      if (.not.allocated(lev%sm%sv)) then 
+        allocate(lev%sm%sv,mold=val,stat=info) 
+        if (info /= 0) then
+          info = 3111
+          return
         end if
-        if (.not.allocated(lv%sm2a%sv)) then 
-          allocate(lv%sm2a%sv,mold=val,stat=info) 
+      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 ((ipos_ == amg_smooth_post_).or. &
+       ((ipos_ == amg_smooth_both_).and.(allocated(lev%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 (info /= 0) then
             info = 3111
             return
           end if
         end if
-        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
-
+      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
 
-  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

@@ -1,333 +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   
-!        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,132 +35,129 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_build_impl
+subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
   use psb_base_mod
-  
-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
+  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
 
-    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')
+  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
     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
+    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
-      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
+    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
       end if
     end if
+  end if
+  
+  if (any((/present(amold),present(vmold),present(imold)/))) &
+       & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
 
-    if (any((/present(amold),present(vmold),present(imold)/))) &
-         & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
-
-    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_build
-end submodule amg_d_base_onelev_build_impl
+end subroutine amg_d_base_onelev_build

amgprec/impl/level/amg_d_base_onelev_check.f90

@@ -35,60 +35,59 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_check_impl
+subroutine amg_d_base_onelev_check(lv,info)
+  
   use psb_base_mod
+  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_check
 
-contains
-  module subroutine amg_d_base_onelev_check(lv,info)
-    Implicit None
+  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'
+  ! 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 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)
+  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%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 (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
+  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
 
-  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
+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
+    res = associated(smp, sm)
+  end function inner_check
+  
+end subroutine amg_d_base_onelev_check

amgprec/impl/level/amg_d_base_onelev_cnv.f90

@@ -35,36 +35,33 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_cnv_impl
-  use psb_base_mod
+subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
   
-contains
-  module subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
+  use psb_base_mod
+  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_cnv
+  implicit none 
 
-    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
 
-    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
 
-    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
+  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

amgprec/impl/level/amg_d_base_onelev_csetc.F90

@@ -35,309 +35,312 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !
 !
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_csetc_impl
+subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
+
   use psb_base_mod
-  
-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
+  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
 #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
+  ! 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
 #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
-        ipos_ = amg_smooth_both_
-      end select
-    else
+  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 if
+    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)
+  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 ('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 ('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 ('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 ('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 ('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 ('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 ('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 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 ('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('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)
-#endif
-#ifdef AMG_HAVE_MUMPS 
-      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)
-#endif
-#ifdef AMG_HAVE_UMF
-      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 ('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?')
-          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
-      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 ('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
-      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)
+      !
+      ! 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)
+#endif
+#ifdef AMG_HAVE_MUMPS 
+    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)
+#endif
+#ifdef AMG_HAVE_UMF
+    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 ('ML_CYCLE')
+    lv%parms%ml_cycle      = amg_stringval(val)
 
-    if (info /= psb_success_) goto 9999
+  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
 
-    call psb_erractionrestore(err_act)
-    return
+    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
+
+  call psb_erractionrestore(err_act)
+  return
 
 9999 call psb_error_handler(err_act)
-    return
+  return
 
-  end subroutine amg_d_base_onelev_csetc
-end submodule amg_d_base_onelev_csetc_impl
+end subroutine amg_d_base_onelev_csetc

amgprec/impl/level/amg_d_base_onelev_cseti.F90

@@ -35,259 +35,261 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !
 !
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_cseti_impl
+subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
+
   use psb_base_mod
-  
-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
+  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
 #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_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_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
 #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
-        ipos_ = amg_smooth_both_
-      end select
-    else
+  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 if
+    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)
+  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_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_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_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_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_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_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 (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 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)
-#endif
-#ifdef AMG_HAVE_MUMPS
-      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)
-#endif
-#ifdef AMG_HAVE_UMF
-      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 (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
-      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)
-
+      !
+      ! Do nothing and hope for the best :)
+      !
     end select
-    if (info /= psb_success_) goto 9999
-    call psb_erractionrestore(err_act)
-    return
+    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)
+#endif
+#ifdef AMG_HAVE_MUMPS
+    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)
+#endif
+#ifdef AMG_HAVE_UMF
+    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
+    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
 
 9999 call psb_error_handler(err_act)
-    return
+  return
 
-  end subroutine amg_d_base_onelev_cseti
-end submodule amg_d_base_onelev_cseti_impl
+end subroutine amg_d_base_onelev_cseti

amgprec/impl/level/amg_d_base_onelev_csetr.f90

@@ -35,73 +35,71 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_csetr_impl
-  use psb_base_mod
+subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
   
-contains
-  module subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
+  use psb_base_mod
+  use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_csetr
 
-    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
-          ipos_ = amg_smooth_both_
-        end select
-      else
+  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 if
+      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
+    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
-      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 ((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
-      if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
+    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 submodule amg_d_base_onelev_csetr_impl
+end subroutine amg_d_base_onelev_csetr

amgprec/impl/level/amg_d_base_onelev_descr.f90

@@ -42,116 +42,108 @@
 !         0: normal
 !        >1: increased details 
 !
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_descr_impl
-  use psb_base_mod
+subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
   
-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
+  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_
-    type(psb_ctxt_type) :: pctxt
-    integer(psb_ipk_)   :: pme, pnp
+  ! 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)
+  call psb_erractionsave(err_act)
 
 
-    coarse = (il==nl)
+  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(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
 
-    pctxt = lv%desc_ac%get_ctxt()
-    call psb_info(pctxt,pme,pnp) 
-    write(iout_,*) trim(prefix_)
-    write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
-    write(iout_,*) trim(prefix_)
-    if (il == ilmin) then 
-      call lv%parms%mlcycledsc(iout_,info)
+  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
-    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_)
+    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
     end if
 
-    if (il > 1) then 
+    call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
 
-      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
+    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
-
-      if (coarse.and.allocated(lv%sm)) &
-           & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
     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 submodule amg_d_base_onelev_descr_impl
+end subroutine amg_d_base_onelev_descr

amgprec/impl/level/amg_d_base_onelev_dump.f90

@@ -35,137 +35,135 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_dump_impl
+subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
+     & smoother,solver,tprol,global_num)
+
   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
   
-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"
+  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 (associated(lv%base_desc)) then 
-      ctxt = lv%base_desc%get_context()
-      call psb_info(ctxt,iam,np)
-    else 
-      iam     = -1
-      np      = -1
+    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
-    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
+  end if
+  
+end subroutine amg_d_base_onelev_dump

amgprec/impl/level/amg_d_base_onelev_free.f90

@@ -35,43 +35,41 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_free_impl
-  use psb_base_mod
+subroutine amg_d_base_onelev_free(lv,info)
   
-contains
-  module subroutine amg_d_base_onelev_free(lv,info)
-    implicit none 
+  use psb_base_mod
+  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_free
+  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 submodule amg_d_base_onelev_free_impl
+end subroutine amg_d_base_onelev_free

amgprec/impl/level/amg_d_base_onelev_free_smoothers.f90

@@ -35,28 +35,26 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_dree_smoothers_impl
-  use psb_base_mod
+subroutine amg_d_base_onelev_free_smoothers(lv,info)
   
-contains
-  module subroutine amg_d_base_onelev_free_smoothers(lv,info)
-    implicit none 
+  use psb_base_mod
+  use amg_d_onelev_mod, amg_protect_name =>  amg_d_base_onelev_free_smoothers
+  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 submodule amg_d_base_onelev_dree_smoothers_impl
+end subroutine amg_d_base_onelev_free_smoothers

amgprec/impl/level/amg_d_base_onelev_map_prol.F90

@@ -35,113 +35,101 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_map_prol_impl
+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
   
-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
-      !
+  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
+    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)
+      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,mold=vect_u%v) 
+        
+        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
 !!$        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 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
+        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
 !!$      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 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 subroutine amg_d_base_onelev_map_prol_v
+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(:)
 
-  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
+  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

amgprec/impl/level/amg_d_base_onelev_map_rstr.F90

@@ -36,115 +36,94 @@
 !   
 !  
 
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_map_rstr_impl
+subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
+     &  work,vtx,vty)
   use psb_base_mod
-  
-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
+  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
 
 !!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-    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
-      !
+  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, 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)
+    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)
 !!$        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,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)))
+        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)))
 !!$          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,' 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
+          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
 
-    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
+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(:)
 
-  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
+  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

amgprec/impl/level/amg_d_base_onelev_mat_asb.f90

@@ -83,111 +83,109 @@
 !    info    -  integer, output.
 !               Error code.         
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_mat_asb_impl
+subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
+
   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)
 
-    implicit none
+  ! 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.
 
-    ! 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
+  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)
 
 
-    ! 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.
+  !
+  ! 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
 
-    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")
+  !
+  ! 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
 
-    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
+  call psb_erractionrestore(err_act)
+  return
 
 9999 call psb_error_handler(err_act)
-    return
+  return
 
-  end subroutine amg_d_base_onelev_mat_asb
-end submodule amg_d_base_onelev_mat_asb_impl
+end subroutine amg_d_base_onelev_mat_asb

amgprec/impl/level/amg_d_base_onelev_memory_use.f90

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

amgprec/impl/level/amg_d_base_onelev_setag.f90

@@ -35,50 +35,48 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_setag_impl
+subroutine amg_d_base_onelev_setag(lv,val,info,pos)
+
   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
   
-contains
-  module subroutine amg_d_base_onelev_setag(lv,val,info,pos)
+  ! Local variables
+  integer(psb_ipk_)                :: ipos_
+  character(len=*), parameter      :: name='amg_base_onelev_setag'
 
-    implicit none
+  info = psb_success_
 
-    ! 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) 
+  ! 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
-      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,73 +35,72 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_setsm_impl
+subroutine amg_d_base_onelev_setsm(lev,val,info,pos)
+
   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
   
-contains
-  module subroutine amg_d_base_onelev_setsm(lv,val,info,pos)
-    implicit none
+  ! Local variables
+  integer(psb_ipk_)                      :: ipos_
+  character(len=*), parameter            :: name='amg_base_onelev_setsm'
+  
+  info = psb_success_
 
-    ! 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
+  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 if
-
-    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
-    end if
-
-    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
+  else
+    ipos_ = amg_smooth_both_
+  end if
 
-  end subroutine amg_d_base_onelev_setsm
+  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)
+      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
 
-end submodule amg_d_base_onelev_setsm_impl

amgprec/impl/level/amg_d_base_onelev_setsv.F90

@@ -35,111 +35,110 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_d_onelev_mod)  amg_d_base_onelev_setsv_impl
+subroutine amg_d_base_onelev_setsv(lev,val,info,pos)
+
   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
   
-contains
-  module subroutine amg_d_base_onelev_setsv(lv,val,info,pos)
-    implicit none
+  ! Local variables
+  integer(psb_ipk_)                :: ipos_
+  character(len=*), parameter      :: name='amg_base_onelev_setsv'
 
-    ! 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
+  info = psb_success_
 
-    ! 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
+  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 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) 
+    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)
           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
-    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 ((ipos_ == amg_smooth_post_).or. &
-         ((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then 
-
-
-      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
+      
+      if (.not.allocated(lev%sm%sv)) then 
+        allocate(lev%sm%sv,mold=val,stat=info) 
+        if (info /= 0) then
+          info = 3111
+          return
         end if
-        if (.not.allocated(lv%sm2a%sv)) then 
-          allocate(lv%sm2a%sv,mold=val,stat=info) 
+      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 ((ipos_ == amg_smooth_post_).or. &
+       ((ipos_ == amg_smooth_both_).and.(allocated(lev%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 (info /= 0) then
             info = 3111
             return
           end if
         end if
-        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
-
+      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
 
-  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

@@ -1,333 +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   
-!        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,132 +35,129 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_s_onelev_mod)  amg_s_base_onelev_build_impl
+subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
   use psb_base_mod
-  
-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
+  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
 
-    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')
+  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
     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
+    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
-      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
+    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
       end if
     end if
+  end if
+  
+  if (any((/present(amold),present(vmold),present(imold)/))) &
+       & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
 
-    if (any((/present(amold),present(vmold),present(imold)/))) &
-         & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
-
-    call psb_erractionrestore(err_act)
-    return
+  call psb_erractionrestore(err_act)
+  return
 
 9999 call psb_error_handler(err_act)
 
-    return
+  return
 
-  end subroutine amg_s_base_onelev_build
-end submodule amg_s_base_onelev_build_impl
+end subroutine amg_s_base_onelev_build

amgprec/impl/level/amg_s_base_onelev_check.f90

@@ -35,60 +35,59 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-submodule (amg_s_onelev_mod)  amg_s_base_onelev_check_impl
+subroutine amg_s_base_onelev_check(lv,info)
+  
   use psb_base_mod
+  use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_check
 
-contains
-  module subroutine amg_s_base_onelev_check(lv,info)
-    Implicit None
+  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'
+  ! 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 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)
+  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%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 (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
+  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
 
-  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
+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
+    res = associated(smp, sm)
+  end function inner_check
+  
+end subroutine amg_s_base_onelev_check