mld2p4-2:

mlprec/Makefile
 mlprec/mld_c_base_smoother_impl.f90
 mlprec/mld_c_base_smoother_mod.f90
 mlprec/mld_c_base_solver_impl.f90
 mlprec/mld_c_base_solver_mod.f90
 mlprec/mld_c_onelev_impl.f90
 mlprec/mld_c_onelev_mod.f90
 mlprec/mld_d_base_smoother_impl.f90
 mlprec/mld_d_base_smoother_mod.f90
 mlprec/mld_d_base_solver_impl.f90
 mlprec/mld_d_base_solver_mod.f90
 mlprec/mld_d_onelev_impl.f90
 mlprec/mld_d_onelev_mod.f90
 mlprec/mld_s_base_smoother_impl.f90
 mlprec/mld_s_base_smoother_mod.f90
 mlprec/mld_s_base_solver_impl.f90
 mlprec/mld_s_base_solver_mod.f90
 mlprec/mld_s_ilu_impl.f90
 mlprec/mld_s_onelev_impl.f90
 mlprec/mld_s_onelev_mod.f90
 mlprec/mld_z_base_smoother_impl.f90
 mlprec/mld_z_base_smoother_mod.f90
 mlprec/mld_z_base_solver_impl.f90
 mlprec/mld_z_base_solver_mod.f90
 mlprec/mld_z_onelev_impl.f90
 mlprec/mld_z_onelev_mod.f90

Split module/interface vs. implementation: reduce memory pressure on
build phase.

mlprec/Makefile

@@ -50,22 +50,22 @@ MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zs
 DINNEROBJS= mld_dcoarse_bld.o  mld_dmlprec_bld.o	  \
 	mld_dilu0_fact.o   mld_diluk_fact.o  mld_dilut_fact.o  mld_daggrmap_bld.o \
 	mld_d_dec_map_bld.o mld_dmlprec_aply.o mld_daggrmat_asb.o   \
-	$(DMPFOBJS) 
+	$(DMPFOBJS) mld_d_base_solver_impl.o mld_d_base_smoother_impl.o mld_d_onelev_impl.o
 
 SINNEROBJS= mld_scoarse_bld.o  mld_smlprec_bld.o	  \
 	mld_silu0_fact.o   mld_siluk_fact.o  mld_silut_fact.o  mld_saggrmap_bld.o \
 	mld_s_dec_map_bld.o mld_smlprec_aply.o mld_saggrmat_asb.o   \
-	$(SMPFOBJS) 
+	$(SMPFOBJS)  mld_s_base_solver_impl.o mld_s_base_smoother_impl.o mld_s_onelev_impl.o
 
 ZINNEROBJS= mld_zcoarse_bld.o  mld_zmlprec_bld.o	  \
 	mld_zilu0_fact.o   mld_ziluk_fact.o  mld_zilut_fact.o  mld_zaggrmap_bld.o \
 	mld_z_dec_map_bld.o mld_zmlprec_aply.o mld_zaggrmat_asb.o   \
-	$(ZMPFOBJS) 
+	$(ZMPFOBJS)  mld_z_base_solver_impl.o mld_z_base_smoother_impl.o mld_z_onelev_impl.o
 
 CINNEROBJS= mld_ccoarse_bld.o  mld_cmlprec_bld.o	  \
 	mld_cilu0_fact.o   mld_ciluk_fact.o  mld_cilut_fact.o  mld_caggrmap_bld.o \
 	mld_c_dec_map_bld.o mld_cmlprec_aply.o mld_caggrmat_asb.o   \
-	$(CMPFOBJS) 
+	$(CMPFOBJS)  mld_c_base_solver_impl.o mld_c_base_smoother_impl.o mld_c_onelev_impl.o
 
 
 INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS)

mlprec/mld_c_base_smoother_impl.f90

@@ -0,0 +1,481 @@
+!!$
+!!$ 
+!!$                           MLD2P4  version 2.0
+!!$  MultiLevel Domain Decomposition Parallel Preconditioners Package
+!!$             based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!!$  
+!!$  (C) Copyright 2008,2009,2010
+!!$
+!!$                      Salvatore Filippone  University of Rome Tor Vergata
+!!$                      Alfredo Buttari      CNRS-IRIT, Toulouse
+!!$                      Pasqua D'Ambra       ICAR-CNR, Naples
+!!$                      Daniela di Serafino  Second University of Naples
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the MLD2P4 group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 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.
+!!$ 
+!!$
+
+!
+! Apply: comes in two versions, on plain arrays or on encapsulated
+! vectors.
+! This basic version just applies the local solver, whatever that
+! is. 
+!
+
+subroutine mld_c_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_apply
+  implicit none 
+  type(psb_desc_type), intent(in)             :: desc_data
+  class(mld_c_base_smoother_type), intent(in) :: sm
+  complex(psb_spk_),intent(inout)                :: x(:)
+  complex(psb_spk_),intent(inout)                :: y(:)
+  complex(psb_spk_),intent(in)                   :: alpha,beta
+  character(len=1),intent(in)                 :: trans
+  integer, intent(in)                         :: sweeps
+  complex(psb_spk_),target, intent(inout)        :: work(:)
+  integer, intent(out)                        :: info
+
+  Integer           :: err_act
+  character(len=20) :: name='c_base_smoother_apply'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
+  else
+    info = 1121
+  endif
+  if (info /= psb_success_) then 
+    call psb_errpush(info,name)
+    goto 9999 
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_c_base_smoother_apply
+
+subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
+     &  trans,sweeps,work,info)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_apply_vect
+  implicit none 
+  type(psb_desc_type), intent(in)                :: desc_data
+  class(mld_c_base_smoother_type), intent(inout) :: sm
+  type(psb_c_vect_type),intent(inout)            :: x
+  type(psb_c_vect_type),intent(inout)            :: y
+  complex(psb_spk_),intent(in)                      :: alpha,beta
+  character(len=1),intent(in)                    :: trans
+  integer, intent(in)                            :: sweeps
+  complex(psb_spk_),target, intent(inout)           :: work(:)
+  integer, intent(out)                           :: info
+
+  Integer           :: err_act
+  character(len=20) :: name='c_base_smoother_apply'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
+  else
+    info = 1121
+  endif
+  if (info /= psb_success_) then 
+    call psb_errpush(info,name)
+    goto 9999 
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_c_base_smoother_apply_vect
+
+!
+! Check:
+! 1. Check that we do have a solver object
+! 2. Call its check method
+!
+
+subroutine mld_c_base_smoother_check(sm,info)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_check
+  Implicit None
+
+  ! Arguments
+  class(mld_c_base_smoother_type), intent(inout) :: sm 
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='c_base_smoother_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%check(info)
+  else 
+    info=3111
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_smoother_check
+
+!
+! Set methods: the come in multiple versions according
+! to whether we are setting with integer, real or character
+! input.
+! The basic rule is: if the input refers to a parameter
+! of the smoother, use it, otherwise pass it to the
+! solver object for further processing.
+! Since there are no parameters in the base smoother
+! we just pass everything to the solver object. 
+!
+subroutine mld_c_base_smoother_seti(sm,what,val,info)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_seti
+  Implicit None
+  ! Arguments
+  class(mld_c_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  integer, intent(in)                            :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='c_base_smoother_seti'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_smoother_seti
+
+subroutine mld_c_base_smoother_setc(sm,what,val,info)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_setc
+  Implicit None
+
+  ! Arguments
+  class(mld_c_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  character(len=*), intent(in)                   :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='c_base_smoother_setc'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_smoother_setc
+
+subroutine mld_c_base_smoother_setr(sm,what,val,info)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_setr
+  Implicit None
+
+  ! Arguments
+  class(mld_c_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  real(psb_spk_), intent(in)                     :: val
+  integer, intent(out)                           :: info
+  Integer :: err_act
+  character(len=20)  :: name='c_base_smoother_setr'
+
+  call psb_erractionsave(err_act)
+
+
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_smoother_setr
+
+
+!
+! Build method.
+! At base level we only have to pass data to the inner solver. 
+! AMOLD/VMOLD allow to have any relevant sparse matrix or vector
+! to be stored in a given format. This is essential e.g.
+! when dealing  with GPUs. 
+!
+subroutine mld_c_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_bld
+  Implicit None
+
+  ! Arguments
+  type(psb_cspmat_type), intent(in), target      :: a
+  Type(psb_desc_type), Intent(in)                :: desc_a 
+  class(mld_c_base_smoother_type), intent(inout) :: sm 
+  character, intent(in)                          :: upd
+  integer, intent(out)                           :: info
+  class(psb_c_base_sparse_mat), intent(in), optional :: amold
+  class(psb_c_base_vect_type), intent(in), optional  :: vmold
+  Integer           :: err_act
+  character(len=20) :: name='c_base_smoother_bld'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%build(a,desc_a,upd,info,amold=amold,vmold=vmold)
+  else
+    info = 1121
+    call psb_errpush(info,name)
+  endif
+  if (info /= psb_success_) goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_smoother_bld
+
+!
+! Free method (aka destructor).
+! In most cases we could do without; however
+! for cases where there are data objects allocated outside
+! of the Fortran RTE we need to free them explicitly.
+!
+! Even in that case, we could do without this if FINAL
+! subroutines were supported, which is not the case
+
+! in GNU Fortran up to 4.7. 
+!
+subroutine mld_c_base_smoother_free(sm,info)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name => s
+  Implicit None
+
+  ! Arguments
+  class(mld_c_base_smoother_type), intent(inout) :: sm
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='c_base_smoother_free'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%free(info)
+  end if
+  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
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_smoother_free
+
+!
+! Print a description
+!
+
+subroutine mld_c_base_smoother_descr(sm,info,iout,coarse)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_descr
+  Implicit None
+
+  ! Arguments
+  class(mld_c_base_smoother_type), intent(in) :: sm
+  integer, intent(out)                        :: info
+  integer, intent(in), optional               :: iout
+  logical, intent(in), optional               :: coarse
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_c_base_smoother_descr'
+  integer :: iout_
+  logical      :: coarse_
+
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (present(coarse)) then 
+    coarse_ = coarse
+  else
+    coarse_ = .false.
+  end if
+  if (present(iout)) then 
+    iout_ = iout
+  else 
+    iout_ = 6
+  end if
+
+  if (.not.coarse_) &
+       &  write(iout_,*) 'Base smoother with local solver'
+  if (allocated(sm%sv)) then 
+    call sm%sv%descr(info,iout,coarse)
+    if (info /= psb_success_) then 
+      info = psb_err_from_subroutine_ 
+      call psb_errpush(info,name,a_err='Local solver')
+      goto 9999
+    end if
+  end if
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_smoother_descr
+
+!
+! Dump 
+! to file, for debugging purposes.
+!
+subroutine mld_c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_dmp
+  implicit none 
+  class(mld_c_base_smoother_type), intent(in) :: sm
+  integer, intent(in)              :: ictxt,level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: smoother, solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: smoother_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_smth_c"
+  end if
+
+  call psb_info(ictxt,iam,np)
+
+  if (present(smoother)) then 
+    smoother_ = smoother
+  else
+    smoother_ = .false. 
+  end if
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  ! At base level do nothing for the smoother
+  if (allocated(sm%sv)) &
+       & call sm%sv%dump(ictxt,level,info,solver=solver)
+
+end subroutine mld_c_base_smoother_dmp
+

mlprec/mld_c_base_smoother_mod.f90

@@ -54,7 +54,8 @@
 module mld_c_base_smoother_mod
 
   use mld_c_base_solver_mod
-  use psb_base_mod, only : psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type
+  use psb_base_mod, only : psb_desc_type, psb_cspmat_type, psb_long_int_k_,&
+       & psb_c_vect_type, psb_c_base_vect_type, psb_c_base_sparse_mat, psb_spk_
   
   !
   !
@@ -91,32 +92,155 @@ module mld_c_base_smoother_mod
   type  mld_c_base_smoother_type
     class(mld_c_base_solver_type), allocatable :: sv
   contains
-    procedure, pass(sm) :: check => c_base_smoother_check
+    procedure, pass(sm) :: check => mld_c_base_smoother_check
-    procedure, pass(sm) :: dump  => c_base_smoother_dmp
+    procedure, pass(sm) :: dump  => mld_c_base_smoother_dmp
-    procedure, pass(sm) :: build => c_base_smoother_bld
+    procedure, pass(sm) :: build => mld_c_base_smoother_bld
-    procedure, pass(sm) :: apply_v => c_base_smoother_apply_vect
+    procedure, pass(sm) :: apply_v => mld_c_base_smoother_apply_vect
-    procedure, pass(sm) :: apply_a => c_base_smoother_apply
+    procedure, pass(sm) :: apply_a => mld_c_base_smoother_apply
     generic, public     :: apply => apply_a, apply_v
-    procedure, pass(sm) :: free  => c_base_smoother_free
+    procedure, pass(sm) :: free  => mld_c_base_smoother_free
-    procedure, pass(sm) :: seti  => c_base_smoother_seti
+    procedure, pass(sm) :: seti  => mld_c_base_smoother_seti
-    procedure, pass(sm) :: setc  => c_base_smoother_setc
+    procedure, pass(sm) :: setc  => mld_c_base_smoother_setc
-    procedure, pass(sm) :: setr  => c_base_smoother_setr
+    procedure, pass(sm) :: setr  => mld_c_base_smoother_setr
     generic, public     :: set   => seti, setc, setr
     procedure, pass(sm) :: default => c_base_smoother_default
-    procedure, pass(sm) :: descr =>   c_base_smoother_descr
+    procedure, pass(sm) :: descr =>   mld_c_base_smoother_descr
     procedure, pass(sm) :: sizeof =>  c_base_smoother_sizeof
     procedure, pass(sm) :: get_nzeros => c_base_smoother_get_nzeros
   end type mld_c_base_smoother_type
 
 
-  private :: c_base_smoother_bld,   c_base_smoother_apply, &
+  private :: c_base_smoother_sizeof, &
-       &  c_base_smoother_free,  c_base_smoother_seti, &
+       &  c_base_smoother_default, c_base_smoother_get_nzeros
-       &  c_base_smoother_setc,  c_base_smoother_setr,&
+
-       &  c_base_smoother_descr, c_base_smoother_sizeof, &
+
-       &  c_base_smoother_default, c_base_smoother_check, &
+
-       &  c_base_smoother_dmp, c_base_smoother_apply_vect, &
+  interface mld_c_base_smoother_apply
-       &  c_base_smoother_get_nzeros
+    subroutine mld_c_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
-
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+       & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      type(psb_desc_type), intent(in)             :: desc_data
+      class(mld_c_base_smoother_type), intent(in) :: sm
+      complex(psb_spk_),intent(inout)                :: x(:)
+      complex(psb_spk_),intent(inout)                :: y(:)
+      complex(psb_spk_),intent(in)                   :: alpha,beta
+      character(len=1),intent(in)                 :: trans
+      integer, intent(in)                         :: sweeps
+      complex(psb_spk_),target, intent(inout)        :: work(:)
+      integer, intent(out)                        :: info
+    end subroutine mld_c_base_smoother_apply
+  end interface mld_c_base_smoother_apply
+  
+  interface mld_c_base_smoother_apply_vect
+    subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
+         &  trans,sweeps,work,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      type(psb_desc_type), intent(in)                :: desc_data
+      class(mld_c_base_smoother_type), intent(inout) :: sm
+      type(psb_c_vect_type),intent(inout)            :: x
+      type(psb_c_vect_type),intent(inout)            :: y
+      complex(psb_spk_),intent(in)                      :: alpha,beta
+      character(len=1),intent(in)                    :: trans
+      integer, intent(in)                            :: sweeps
+      complex(psb_spk_),target, intent(inout)           :: work(:)
+      integer, intent(out)                           :: info
+    end subroutine mld_c_base_smoother_apply_vect
+  end interface mld_c_base_smoother_apply_vect
+  
+  interface mld_c_base_smoother_check
+    subroutine mld_c_base_smoother_check(sm,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      ! Arguments
+      class(mld_c_base_smoother_type), intent(inout) :: sm 
+      integer, intent(out)                   :: info
+    end subroutine mld_c_base_smoother_check
+  end interface mld_c_base_smoother_check
+  
+  interface mld_c_base_smoother_seti
+    subroutine mld_c_base_smoother_seti(sm,what,val,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      ! Arguments
+      class(mld_c_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      integer, intent(in)                            :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_c_base_smoother_seti
+  end interface mld_c_base_smoother_seti
+  
+  interface mld_c_base_smoother_setc
+    subroutine mld_c_base_smoother_setc(sm,what,val,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      class(mld_c_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      character(len=*), intent(in)                   :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_c_base_smoother_setc
+  end interface mld_c_base_smoother_setc
+  
+  interface mld_c_base_smoother_setr
+    subroutine mld_c_base_smoother_setr(sm,what,val,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      ! Arguments
+      class(mld_c_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      real(psb_spk_), intent(in)                     :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_c_base_smoother_setr
+  end interface mld_c_base_smoother_setr
+  
+  interface mld_c_base_smoother_bld
+    subroutine mld_c_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      ! Arguments
+      type(psb_cspmat_type), intent(in), target      :: a
+      Type(psb_desc_type), Intent(in)                :: desc_a 
+      class(mld_c_base_smoother_type), intent(inout) :: sm 
+      character, intent(in)                          :: upd
+      integer, intent(out)                           :: info
+      class(psb_c_base_sparse_mat), intent(in), optional :: amold
+      class(psb_c_base_vect_type), intent(in), optional  :: vmold
+    end subroutine mld_c_base_smoother_bld
+  end interface mld_c_base_smoother_bld
+  
+  interface mld_c_base_smoother_free
+    subroutine mld_c_base_smoother_free(sm,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      ! Arguments
+      class(mld_c_base_smoother_type), intent(inout) :: sm
+      integer, intent(out)                           :: info
+    end subroutine mld_c_base_smoother_free
+  end interface mld_c_base_smoother_free
+  
+  interface mld_c_base_smoother_descr
+    subroutine mld_c_base_smoother_descr(sm,info,iout,coarse)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      ! Arguments
+      class(mld_c_base_smoother_type), intent(in) :: sm
+      integer, intent(out)                        :: info
+      integer, intent(in), optional               :: iout
+      logical, intent(in), optional               :: coarse
+    end subroutine mld_c_base_smoother_descr
+  end interface mld_c_base_smoother_descr
+  
+  interface mld_c_base_smoother_dmp
+    subroutine mld_c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_smoother_type
+      class(mld_c_base_smoother_type), intent(in) :: sm
+      integer, intent(in)              :: ictxt,level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: smoother, solver
+    end subroutine mld_c_base_smoother_dmp
+  end interface mld_c_base_smoother_dmp
   
 contains
   !
@@ -149,451 +273,6 @@ contains
     return
   end function c_base_smoother_sizeof
 
-
-  !
-  ! Apply: comes in two versions, on plain arrays or on encapsulated
-  ! vectors.
-  ! This basic version just applies the local solver, whatever that
-  ! is. 
-  !
-
-  subroutine c_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)             :: desc_data
-    class(mld_c_base_smoother_type), intent(in) :: sm
-    complex(psb_spk_),intent(inout)                :: x(:)
-    complex(psb_spk_),intent(inout)                :: y(:)
-    complex(psb_spk_),intent(in)                   :: alpha,beta
-    character(len=1),intent(in)                 :: trans
-    integer, intent(in)                         :: sweeps
-    complex(psb_spk_),target, intent(inout)        :: work(:)
-    integer, intent(out)                        :: info
-    
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_apply'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
-    else
-      info = 1121
-    endif
-    if (info /= psb_success_) then 
-      call psb_errpush(info,name)
-      goto 9999 
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine c_base_smoother_apply
-
-  subroutine c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
-       &  trans,sweeps,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)                :: desc_data
-    class(mld_c_base_smoother_type), intent(inout) :: sm
-    type(psb_c_vect_type),intent(inout)            :: x
-    type(psb_c_vect_type),intent(inout)            :: y
-    complex(psb_spk_),intent(in)                      :: alpha,beta
-    character(len=1),intent(in)                    :: trans
-    integer, intent(in)                            :: sweeps
-    complex(psb_spk_),target, intent(inout)           :: work(:)
-    integer, intent(out)                           :: info
-    
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_apply'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
-    else
-      info = 1121
-    endif
-    if (info /= psb_success_) then 
-      call psb_errpush(info,name)
-      goto 9999 
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine c_base_smoother_apply_vect
-
-  !
-  ! Check:
-  ! 1. Check that we do have a solver object
-  ! 2. Call its check method
-  !
-
-  subroutine c_base_smoother_check(sm,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_smoother_type), intent(inout) :: sm 
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%check(info)
-    else 
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_smoother_check
-
-  !
-  ! Set methods: the come in multiple versions according
-  ! to whether we are setting with integer, real or character
-  ! input.
-  ! The basic rule is: if the input refers to a parameter
-  ! of the smoother, use it, otherwise pass it to the
-  ! solver object for further processing.
-  ! Since there are no parameters in the base smoother
-  ! we just pass everything to the solver object. 
-  !
-  subroutine c_base_smoother_seti(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    integer, intent(in)                            :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_seti'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_smoother_seti
-
-  subroutine c_base_smoother_setc(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    character(len=*), intent(in)                   :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_setc'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_smoother_setc
-  
-  subroutine c_base_smoother_setr(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    real(psb_spk_), intent(in)                     :: val
-    integer, intent(out)                           :: info
-    Integer :: err_act
-    character(len=20)  :: name='d_base_smoother_setr'
-
-    call psb_erractionsave(err_act)
-
-
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_smoother_setr
-
-
-  !
-  ! Build method.
-  ! At base level we only have to pass data to the inner solver. 
-  ! AMOLD/VMOLD allow to have any relevant sparse matrix or vector
-  ! to be stored in a given format. This is essential e.g.
-  ! when dealing  with GPUs. 
-  !
-  subroutine c_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    type(psb_cspmat_type), intent(in), target      :: a
-    Type(psb_desc_type), Intent(in)                :: desc_a 
-    class(mld_c_base_smoother_type), intent(inout) :: sm 
-    character, intent(in)                          :: upd
-    integer, intent(out)                           :: info
-    class(psb_c_base_sparse_mat), intent(in), optional :: amold
-    class(psb_c_base_vect_type), intent(in), optional  :: vmold
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_bld'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%build(a,desc_a,upd,info,amold=amold,vmold=vmold)
-    else
-      info = 1121
-      call psb_errpush(info,name)
-    endif
-    if (info /= psb_success_) goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_smoother_bld
-
-  !
-  ! Free method (aka destructor).
-  ! In most cases we could do without; however
-  ! for cases where there are data objects allocated outside
-  ! of the Fortran RTE we need to free them explicitly.
-  !
-  ! Even in that case, we could do without this if FINAL
-  ! subroutines were supported, which is not the case
-  ! in GNU Fortran up to 4.7. 
-  !
-  subroutine c_base_smoother_free(sm,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_smoother_type), intent(inout) :: sm
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_free'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    
-    if (allocated(sm%sv)) then 
-      call sm%sv%free(info)
-    end if
-    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
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_smoother_free
-
-  !
-  ! Print a description
-  !
-
-  subroutine c_base_smoother_descr(sm,info,iout,coarse)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_smoother_type), intent(in) :: sm
-    integer, intent(out)                        :: info
-    integer, intent(in), optional               :: iout
-    logical, intent(in), optional               :: coarse
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_c_base_smoother_descr'
-    integer :: iout_
-    logical      :: coarse_
-
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (present(coarse)) then 
-      coarse_ = coarse
-    else
-      coarse_ = .false.
-    end if
-    if (present(iout)) then 
-      iout_ = iout
-    else 
-      iout_ = 6
-    end if
-
-    if (.not.coarse_) &
-         &  write(iout_,*) 'Base smoother with local solver'
-    if (allocated(sm%sv)) then 
-      call sm%sv%descr(info,iout,coarse)
-      if (info /= psb_success_) then 
-        info = psb_err_from_subroutine_ 
-        call psb_errpush(info,name,a_err='Local solver')
-        goto 9999
-      end if
-    end if
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_smoother_descr
-
-  !
-  ! Dump 
-  ! to file, for debugging purposes.
-  !
-  subroutine c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_c_base_smoother_type), intent(in) :: sm
-    integer, intent(in)              :: ictxt,level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: smoother, solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: smoother_
-    !  len of prefix_ 
-
-    info = 0
-
-    if (present(prefix)) then 
-      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-    else
-      prefix_ = "dump_smth_d"
-    end if
-
-    call psb_info(ictxt,iam,np)
-
-    if (present(smoother)) then 
-      smoother_ = smoother
-    else
-      smoother_ = .false. 
-    end if
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    ! At base level do nothing for the smoother
-    if (allocated(sm%sv)) &
-         & call sm%sv%dump(ictxt,level,info,solver=solver)
-
-  end subroutine c_base_smoother_dmp
-
   !
   ! Set sensible defaults.
   ! To be called immediately after allocation
@@ -610,5 +289,4 @@ contains
   end subroutine c_base_smoother_default
 
 
-
 end module mld_c_base_smoother_mod

mlprec/mld_c_base_solver_impl.f90

@@ -0,0 +1,338 @@
+!
+! Apply: comes in two versions, on plain arrays or on encapsulated
+! vectors.
+! The base version throws an error, since it means that no explicit
+! choice was made. 
+! Question: would it make sense to transform the base version into
+! the ID version, i.e. "base_solver" is the identity operator? 
+! 
+
+subroutine mld_c_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_apply
+  implicit none 
+  type(psb_desc_type), intent(in)           :: desc_data
+  class(mld_c_base_solver_type), intent(in) :: sv
+  complex(psb_spk_),intent(inout)              :: x(:)
+  complex(psb_spk_),intent(inout)              :: y(:)
+  complex(psb_spk_),intent(in)                 :: alpha,beta
+  character(len=1),intent(in)               :: trans
+  complex(psb_spk_),target, intent(inout)      :: work(:)
+  integer, intent(out)                      :: info
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_c_base_solver_apply
+
+subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_apply_vect
+  implicit none 
+  type(psb_desc_type), intent(in)              :: desc_data
+  class(mld_c_base_solver_type), intent(inout) :: sv
+  type(psb_c_vect_type),intent(inout)          :: x
+  type(psb_c_vect_type),intent(inout)          :: y
+  complex(psb_spk_),intent(in)                    :: alpha,beta
+  character(len=1),intent(in)                  :: trans
+  complex(psb_spk_),target, intent(inout)         :: work(:)
+  integer, intent(out)                         :: info
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_c_base_solver_apply_vect
+
+
+!
+! Build
+! The base version throws an error, since it means that no explicit
+! choice was made. 
+!
+subroutine mld_c_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_bld
+  Implicit None
+  ! Arguments
+  type(psb_cspmat_type), intent(in), target           :: a
+  Type(psb_desc_type), Intent(in)                     :: desc_a 
+  class(mld_c_base_solver_type), intent(inout)        :: sv
+  character, intent(in)                               :: upd
+  integer, intent(out)                                :: info
+  type(psb_cspmat_type), intent(in), target, optional :: b
+  class(psb_c_base_sparse_mat), intent(in), optional  :: amold
+  class(psb_c_base_vect_type), intent(in), optional   :: vmold
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_bld'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_solver_bld
+
+subroutine mld_c_base_solver_check(sv,info)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_check
+  Implicit None
+  ! Arguments
+  class(mld_c_base_solver_type), intent(inout) :: sv
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_solver_check
+
+!
+! Set.
+! The base version does nothing; the principle is that
+! SET acts on what is known, and delegates what is unknown.
+! Since we are at the bottom of the hierarchy, there's no one
+! to delegate, so we do nothing. 
+!
+subroutine mld_c_base_solver_seti(sv,what,val,info)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_seti
+  Implicit None
+  ! Arguments
+  class(mld_c_base_solver_type), intent(inout) :: sv 
+  integer, intent(in)                          :: what 
+  integer, intent(in)                          :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_seti'
+
+  ! Correct action here is doing nothing. 
+  info = 0
+
+  return
+end subroutine mld_c_base_solver_seti
+
+subroutine mld_c_base_solver_setc(sv,what,val,info)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_setc
+  Implicit None
+  ! Arguments
+  class(mld_c_base_solver_type), intent(inout) :: sv
+  integer, intent(in)                          :: what 
+  character(len=*), intent(in)                 :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act, ival 
+  character(len=20) :: name='d_base_solver_setc'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  call mld_stringval(val,ival,info)
+  if (info == psb_success_) call sv%set(what,ival,info)
+
+  if (info /= psb_success_) goto 9999
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_solver_setc
+
+subroutine mld_c_base_solver_setr(sv,what,val,info)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_setr
+  Implicit None
+  ! Arguments
+  class(mld_c_base_solver_type), intent(inout) :: sv 
+  integer, intent(in)                          :: what 
+  real(psb_spk_), intent(in)                   :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_setr'
+
+
+  ! Correct action here is doing nothing. 
+  info = 0
+
+  return
+end subroutine mld_c_base_solver_setr
+
+!
+! Free
+! The base version throws an error, since it means that no explicit
+! choice was made. IS THIS CORRECT? I suspect it would be better
+! to be silent here, to cover reallocation. 
+!
+subroutine mld_c_base_solver_free(sv,info)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_free
+  Implicit None
+  ! Arguments
+  class(mld_c_base_solver_type), intent(inout) :: sv
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_free'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_solver_free
+
+subroutine mld_c_base_solver_descr(sv,info,iout,coarse)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_descr
+  Implicit None
+  ! Arguments
+  class(mld_c_base_solver_type), intent(in) :: sv
+  integer, intent(out)                      :: info
+  integer, intent(in), optional             :: iout
+  logical, intent(in), optional             :: coarse
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_c_base_solver_descr'
+  integer      :: iout_
+
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_solver_descr
+
+!
+! Dump. For debugging purposes. 
+!
+subroutine mld_c_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
+  use psb_base_mod
+  use mld_c_base_solver_mod, mld_protect_name =>  mld_c_base_solver_dmp
+  implicit none 
+  class(mld_c_base_solver_type), intent(in) :: sv
+  integer, intent(in)              :: ictxt,level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: solver_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_slv_c"
+  end if
+
+  call psb_info(ictxt,iam,np)
+
+  if (present(solver)) then 
+    solver_ = solver
+  else
+    solver_ = .false. 
+  end if
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  ! At base level do nothing for the solver
+
+end subroutine mld_c_base_solver_dmp
+

mlprec/mld_c_base_solver_mod.f90

@@ -54,7 +54,8 @@
 module mld_c_base_solver_mod
 
   use mld_base_prec_type
-  use psb_base_mod, only : psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type
+  use psb_base_mod, only : psb_desc_type, psb_cspmat_type, psb_long_int_k_, &
+       & psb_c_vect_type, psb_c_base_vect_type, psb_c_base_sparse_mat, psb_spk_
   !
   ! 
   ! Type: mld_T_base_solver_type.
@@ -83,32 +84,179 @@ module mld_c_base_solver_mod
 
   type mld_c_base_solver_type
   contains
-    procedure, pass(sv) :: check => c_base_solver_check
+    procedure, pass(sv) :: check => mld_c_base_solver_check
-    procedure, pass(sv) :: dump  => c_base_solver_dmp
+    procedure, pass(sv) :: dump  => mld_c_base_solver_dmp
-    procedure, pass(sv) :: build => c_base_solver_bld
+    procedure, pass(sv) :: build => mld_c_base_solver_bld
-    procedure, pass(sv) :: apply_v => c_base_solver_apply_vect
+    procedure, pass(sv) :: apply_v => mld_c_base_solver_apply_vect
-    procedure, pass(sv) :: apply_a => c_base_solver_apply
+    procedure, pass(sv) :: apply_a => mld_c_base_solver_apply
     generic, public     :: apply => apply_a, apply_v
-    procedure, pass(sv) :: free  => c_base_solver_free
+    procedure, pass(sv) :: free  => mld_c_base_solver_free
-    procedure, pass(sv) :: seti  => c_base_solver_seti
+    procedure, pass(sv) :: seti  => mld_c_base_solver_seti
-    procedure, pass(sv) :: setc  => c_base_solver_setc
+    procedure, pass(sv) :: setc  => mld_c_base_solver_setc
-    procedure, pass(sv) :: setr  => c_base_solver_setr
+    procedure, pass(sv) :: setr  => mld_c_base_solver_setr
     generic, public     :: set   => seti, setc, setr
     procedure, pass(sv) :: default => c_base_solver_default
-    procedure, pass(sv) :: descr   => c_base_solver_descr
+    procedure, pass(sv) :: descr   => mld_c_base_solver_descr
     procedure, pass(sv) :: sizeof  => c_base_solver_sizeof
     procedure, pass(sv) :: get_nzeros => c_base_solver_get_nzeros
   end type mld_c_base_solver_type
 
-  private :: c_base_solver_bld,  c_base_solver_apply, &
+  private :: c_base_solver_sizeof, c_base_solver_default,&
-       &  c_base_solver_free,    c_base_solver_seti, &
-       &  c_base_solver_setc,    c_base_solver_setr, &
-       &  c_base_solver_descr,   c_base_solver_sizeof, &
-       &  c_base_solver_default, c_base_solver_check,&
-       &  c_base_solver_dmp, c_base_solver_apply_vect, &
        &  c_base_solver_get_nzeros
 
 
+  interface  mld_c_base_solver_apply
+    subroutine mld_c_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+       & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+      type(psb_desc_type), intent(in)           :: desc_data
+      class(mld_c_base_solver_type), intent(in) :: sv
+      complex(psb_spk_),intent(inout)              :: x(:)
+      complex(psb_spk_),intent(inout)              :: y(:)
+      complex(psb_spk_),intent(in)                 :: alpha,beta
+      character(len=1),intent(in)               :: trans
+      complex(psb_spk_),target, intent(inout)      :: work(:)
+      integer, intent(out)                      :: info
+    end subroutine mld_c_base_solver_apply
+  end interface mld_c_base_solver_apply
+  
+      
+  interface mld_c_base_solver_apply_vect
+    subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+      
+      type(psb_desc_type), intent(in)              :: desc_data
+      class(mld_c_base_solver_type), intent(inout) :: sv
+      type(psb_c_vect_type),intent(inout)          :: x
+      type(psb_c_vect_type),intent(inout)          :: y
+      complex(psb_spk_),intent(in)                    :: alpha,beta
+      character(len=1),intent(in)                  :: trans
+      complex(psb_spk_),target, intent(inout)         :: work(:)
+      integer, intent(out)                         :: info
+    end subroutine mld_c_base_solver_apply_vect
+  end interface mld_c_base_solver_apply_vect
+  
+  interface mld_c_base_solver_bld
+    subroutine mld_c_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+       & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      type(psb_cspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(in)                     :: desc_a 
+      class(mld_c_base_solver_type), intent(inout)        :: sv
+      character, intent(in)                               :: upd
+      integer, intent(out)                                :: info
+      type(psb_cspmat_type), intent(in), target, optional :: b
+      class(psb_c_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_c_base_vect_type), intent(in), optional   :: vmold
+    end subroutine mld_c_base_solver_bld
+  end interface mld_c_base_solver_bld
+  
+  interface mld_c_base_solver_check
+    subroutine mld_c_base_solver_check(sv,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+
+      Implicit None
+      
+      ! Arguments
+      class(mld_c_base_solver_type), intent(inout) :: sv
+      integer, intent(out)                   :: info
+    end subroutine mld_c_base_solver_check
+  end interface mld_c_base_solver_check
+  
+  interface mld_c_base_solver_seti
+    subroutine mld_c_base_solver_seti(sv,what,val,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      class(mld_c_base_solver_type), intent(inout) :: sv 
+      integer, intent(in)                          :: what 
+      integer, intent(in)                          :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_c_base_solver_seti
+  end interface mld_c_base_solver_seti
+  
+  interface  mld_c_base_solver_setc
+    subroutine mld_c_base_solver_setc(sv,what,val,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_c_base_solver_type), intent(inout) :: sv
+      integer, intent(in)                          :: what 
+      character(len=*), intent(in)                 :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_c_base_solver_setc
+  end interface mld_c_base_solver_setc
+  
+  interface  mld_c_base_solver_setr
+    subroutine mld_c_base_solver_setr(sv,what,val,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+            
+      Implicit None
+      
+      ! Arguments
+      class(mld_c_base_solver_type), intent(inout) :: sv 
+      integer, intent(in)                          :: what 
+      real(psb_spk_), intent(in)                   :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_c_base_solver_setr
+  end interface mld_c_base_solver_setr
+  
+  interface  mld_c_base_solver_free
+    subroutine mld_c_base_solver_free(sv,info)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_c_base_solver_type), intent(inout) :: sv
+      integer, intent(out)                         :: info
+    end subroutine mld_c_base_solver_free
+  end interface mld_c_base_solver_free
+  
+  interface  mld_c_base_solver_descr
+    subroutine mld_c_base_solver_descr(sv,info,iout,coarse)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      class(mld_c_base_solver_type), intent(in) :: sv
+      integer, intent(out)                      :: info
+      integer, intent(in), optional             :: iout
+      logical, intent(in), optional             :: coarse
+
+    end subroutine mld_c_base_solver_descr
+  end interface mld_c_base_solver_descr
+  
+  interface  mld_c_base_solver_dmp
+    subroutine mld_c_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
+      import :: psb_desc_type, psb_cspmat_type,  psb_c_base_sparse_mat, &
+           & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, mld_c_base_solver_type
+      
+      implicit none 
+      class(mld_c_base_solver_type), intent(in) :: sv
+      integer, intent(in)              :: ictxt,level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: solver
+    end subroutine mld_c_base_solver_dmp
+  end interface mld_c_base_solver_dmp
+  
+
+
 
 contains
   !
@@ -135,354 +283,6 @@ contains
     val = 0
   end function c_base_solver_get_nzeros
 
-  
-  !
-  ! Apply: comes in two versions, on plain arrays or on encapsulated
-  ! vectors.
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. 
-  ! Question: would it make sense to transform the base version into
-  ! the ID version, i.e. "base_solver" is the identity operator? 
-  ! 
-
-  subroutine c_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)           :: desc_data
-    class(mld_c_base_solver_type), intent(in) :: sv
-    complex(psb_spk_),intent(inout)              :: x(:)
-    complex(psb_spk_),intent(inout)              :: y(:)
-    complex(psb_spk_),intent(in)                 :: alpha,beta
-    character(len=1),intent(in)               :: trans
-    complex(psb_spk_),target, intent(inout)      :: work(:)
-    integer, intent(out)                      :: info
-    
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_apply'
-
-    call psb_erractionsave(err_act)
-    
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine c_base_solver_apply
-
-  subroutine c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)              :: desc_data
-    class(mld_c_base_solver_type), intent(inout) :: sv
-    type(psb_c_vect_type),intent(inout)          :: x
-    type(psb_c_vect_type),intent(inout)          :: y
-    complex(psb_spk_),intent(in)                    :: alpha,beta
-    character(len=1),intent(in)                  :: trans
-    complex(psb_spk_),target, intent(inout)         :: work(:)
-    integer, intent(out)                         :: info
-    
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_apply'
-
-    call psb_erractionsave(err_act)
-    
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine c_base_solver_apply_vect
-
-
-  !
-  ! Build
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. 
-  !
-  subroutine c_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    type(psb_cspmat_type), intent(in), target           :: a
-    Type(psb_desc_type), Intent(in)                     :: desc_a 
-    class(mld_c_base_solver_type), intent(inout)        :: sv
-    character, intent(in)                               :: upd
-    integer, intent(out)                                :: info
-    type(psb_cspmat_type), intent(in), target, optional :: b
-    class(psb_c_base_sparse_mat), intent(in), optional  :: amold
-    class(psb_c_base_vect_type), intent(in), optional   :: vmold
-
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_bld'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_solver_bld
-
-  subroutine c_base_solver_check(sv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_solver_type), intent(inout) :: sv
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_solver_check
-
-  !
-  ! Set.
-  ! The base version does nothing; the principle is that
-  ! SET acts on what is known, and delegates what is unknown.
-  ! Since we are at the bottom of the hierarchy, there's no one
-  ! to delegate, so we do nothing. 
-  !
-  subroutine c_base_solver_seti(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_solver_type), intent(inout) :: sv 
-    integer, intent(in)                          :: what 
-    integer, intent(in)                          :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_seti'
-    
-    ! Correct action here is doing nothing. 
-    info = 0
-    
-    return
-  end subroutine c_base_solver_seti
-
-  subroutine c_base_solver_setc(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_solver_type), intent(inout) :: sv
-    integer, intent(in)                          :: what 
-    character(len=*), intent(in)                 :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act, ival 
-    character(len=20) :: name='d_base_solver_setc'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    call mld_stringval(val,ival,info)
-    if (info == psb_success_) call sv%set(what,ival,info)
-
-    if (info /= psb_success_) goto 9999
-
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_solver_setc
-  
-  subroutine c_base_solver_setr(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_solver_type), intent(inout) :: sv 
-    integer, intent(in)                          :: what 
-    real(psb_spk_), intent(in)                   :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_setr'
-
-    
-    ! Correct action here is doing nothing. 
-    info = 0
-    
-    return
-  end subroutine c_base_solver_setr
-
-  !
-  ! Free
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. IS THIS CORRECT? I suspect it would be better
-  ! to be silent here, to cover reallocation. 
-  !
-  subroutine c_base_solver_free(sv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_solver_type), intent(inout) :: sv
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_free'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_solver_free
-
-  subroutine c_base_solver_descr(sv,info,iout,coarse)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_c_base_solver_type), intent(in) :: sv
-    integer, intent(out)                      :: info
-    integer, intent(in), optional             :: iout
-    logical, intent(in), optional             :: coarse
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_c_base_solver_descr'
-    integer      :: iout_
-
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_solver_descr
-
-  !
-  ! Dump. For debugging purposes. 
-  !
-  subroutine c_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_c_base_solver_type), intent(in) :: sv
-    integer, intent(in)              :: ictxt,level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: solver_
-    !  len of prefix_ 
-
-    info = 0
-
-    if (present(prefix)) then 
-      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-    else
-      prefix_ = "dump_slv_d"
-    end if
-
-    call psb_info(ictxt,iam,np)
-
-    if (present(solver)) then 
-      solver_ = solver
-    else
-      solver_ = .false. 
-    end if
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    ! At base level do nothing for the solver
-
-  end subroutine c_base_solver_dmp
-
   subroutine c_base_solver_default(sv) 
     implicit none 
     ! Arguments
@@ -492,6 +292,4 @@ contains
     return
   end subroutine c_base_solver_default
 
-
-
 end module mld_c_base_solver_mod

mlprec/mld_c_onelev_impl.f90

@@ -0,0 +1,459 @@
+!!$
+!!$ 
+!!$                           MLD2P4  version 2.0
+!!$  MultiLevel Domain Decomposition Parallel Preconditioners Package
+!!$             based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!!$  
+!!$  (C) Copyright 2008,2009,2010
+!!$
+!!$                      Salvatore Filippone  University of Rome Tor Vergata
+!!$                      Alfredo Buttari      CNRS-IRIT, Toulouse
+!!$                      Pasqua D'Ambra       ICAR-CNR, Naples
+!!$                      Daniela di Serafino  Second University of Naples
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the MLD2P4 group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$
+
+!
+! Subroutine: mld_file_onelev_descr
+! Version: complex
+!
+!  This routine prints a description of the preconditioner to the standard 
+!  output or to a file. It must be called after the preconditioner has been
+!  built by mld_precbld.
+!
+! Arguments:
+!  p       -  type(mld_Tprec_type), input.
+!             The preconditioner data structure to be printed out.
+!  info    -  integer, output.
+!             error code.
+!  iout    -  integer, input, optional.
+!             The id of the file where the preconditioner description
+!             will be printed. If iout is not present, then the standard
+!             output is condidered.
+!
+subroutine mld_c_base_onelev_descr(lv,il,nl,info,iout)
+  use psb_base_mod
+  use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_descr
+  Implicit None
+  ! Arguments
+  class(mld_conelev_type), intent(in) :: lv
+  integer, intent(in)                 :: il,nl
+  integer, intent(out)                :: info
+  integer, intent(in), optional       :: iout
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_c_base_onelev_descr'
+  integer      :: iout_
+  logical      :: coarse
+
+
+  call psb_erractionsave(err_act)
+
+
+  coarse = (il==nl)
+
+  if (present(iout)) then 
+    iout_ = iout
+  else 
+    iout_ = 6
+  end if
+
+  write(iout_,*) 
+  if (il == 2) then 
+    call lv%parms%mldescr(iout_,info)
+    write(iout_,*) 
+  end if
+
+  if (coarse)  then 
+    write(iout_,*) ' Level ',il,' (coarsest)'
+  else
+    write(iout_,*) ' Level ',il
+  end if
+
+  call lv%parms%descr(iout_,info,coarse=coarse)
+
+  if (nl > 1) then 
+    if (allocated(lv%map%naggr)) then
+      write(iout_,*) '  Size of coarse matrix: ', &
+           &  sum(lv%map%naggr(:))
+      write(iout_,*) '  Sizes of aggregates: ', &
+           &  lv%map%naggr(:)
+    end if
+  end if
+
+  if (coarse.and.allocated(lv%sm)) &
+       & call lv%sm%descr(info,iout=iout_,coarse=coarse)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_onelev_descr
+
+
+!
+! Subroutines: mld_T_onelev_precfree
+! Version: complex
+!
+!  These routines deallocate the mld_Tonelev_type 
+!
+! Arguments:
+!  p       -  type(mld_Tonelev_type), input.
+!             The data structure to be deallocated.
+!  info    -  integer, output.
+!             error code.
+!
+subroutine mld_c_base_onelev_free(lv,info)
+  use psb_base_mod
+  use mld_conelev_mod, mld_protect_name =>:  mld_T_onelev_precfree
+  implicit none 
+
+  class(mld_conelev_type), intent(inout) :: lv
+  integer, intent(out)                :: info
+  integer :: i
+
+  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. 
+  call lv%sm%free(info)
+
+  call lv%ac%free()
+  if (psb_is_ok_desc(lv%desc_ac)) &
+       & call psb_cdfree(lv%desc_ac,info)
+  call lv%map%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) 
+
+  call lv%nullify()
+
+end subroutine mld_c_base_onelev_free
+
+!
+! Onelevel checks. 
+! The number of Jacobi sweeps to be applied is not
+! tied to the Jacobi smoother: logically, you have
+! a smoother and you can choose to apply it any number
+! of times you like. 
+!
+subroutine mld_c_base_onelev_check(lv,info)
+  use psb_base_mod
+  use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_check
+
+  Implicit None
+
+  ! Arguments
+  class(mld_conelev_type), intent(inout) :: lv 
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='c_base_onelev_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  call mld_check_def(lv%parms%sweeps,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+  call mld_check_def(lv%parms%sweeps_pre,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+  call mld_check_def(lv%parms%sweeps_post,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+
+
+  if (allocated(lv%sm)) then 
+    call lv%sm%check(info)
+  else 
+    info=3111
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_onelev_check
+
+
+! 
+! Set routines:
+! Parameters belonging here are:
+!   Number of smoothing sweeps;
+!   Smoother position;
+!   Aggregation related parameters
+!   Record request on coarse level solver,
+!    for checks on solver vs. smoother nomenclature
+!    reconciliation. 
+! 
+subroutine mld_c_base_onelev_seti(lv,what,val,info)
+  use psb_base_mod
+  use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_seti
+
+  Implicit None
+
+  ! Arguments
+  class(mld_conelev_type), intent(inout) :: lv 
+  integer, intent(in)                          :: what 
+  integer, intent(in)                          :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='c_base_onelev_seti'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  select case (what) 
+
+  case (mld_smoother_sweeps_)
+    lv%parms%sweeps      = val
+    lv%parms%sweeps_pre  = val
+    lv%parms%sweeps_post = val
+
+  case (mld_smoother_sweeps_pre_)
+    lv%parms%sweeps_pre  = val
+
+  case (mld_smoother_sweeps_post_)
+    lv%parms%sweeps_post = val
+
+  case (mld_ml_type_)
+    lv%parms%ml_type       = val
+
+  case (mld_aggr_alg_)
+    lv%parms%aggr_alg      = val
+
+  case (mld_aggr_kind_)
+    lv%parms%aggr_kind     = val
+
+  case (mld_coarse_mat_)
+    lv%parms%coarse_mat    = val
+
+  case (mld_smoother_pos_)
+    lv%parms%smoother_pos  = val
+
+  case (mld_aggr_omega_alg_)
+    lv%parms%aggr_omega_alg= val
+
+  case (mld_aggr_eig_)
+    lv%parms%aggr_eig      = val
+
+  case (mld_aggr_filter_)
+    lv%parms%aggr_filter   = val
+
+  case (mld_coarse_solve_)
+    lv%parms%coarse_solve    = val
+
+  case default
+    if (allocated(lv%sm)) then 
+      call lv%sm%set(what,val,info)
+    end if
+    if (info /= psb_success_) goto 9999
+  end select
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_onelev_seti
+
+subroutine mld_c_base_onelev_setc(lv,what,val,info)
+  use psb_base_mod
+  use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_setc
+
+  Implicit None
+
+  ! Arguments
+  class(mld_conelev_type), intent(inout) :: lv 
+  integer, intent(in)                            :: what 
+  character(len=*), intent(in)                   :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='c_base_onelev_setc'
+  integer :: ival 
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  call mld_stringval(val,ival,info)
+  if (info == psb_success_) call lv%set(what,ival,info)
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_onelev_setc
+
+subroutine mld_c_base_onelev_setr(lv,what,val,info)
+  use psb_base_mod
+  use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_setr
+
+  Implicit None
+
+  ! Arguments
+  class(mld_conelev_type), intent(inout) :: lv 
+  integer, intent(in)                            :: what 
+  real(psb_spk_), intent(in)                     :: val
+  integer, intent(out)                           :: info
+  Integer :: err_act
+  character(len=20)  :: name='c_base_onelev_setr'
+
+  call psb_erractionsave(err_act)
+
+
+  info = psb_success_
+
+  select case (what) 
+
+  case (mld_aggr_omega_val_)
+    lv%parms%aggr_omega_val= val
+
+  case (mld_aggr_thresh_)
+    lv%parms%aggr_thresh   = val
+
+  case default
+    if (allocated(lv%sm)) then 
+      call lv%sm%set(what,val,info)
+    end if
+    if (info /= psb_success_) goto 9999
+  end select
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_c_base_onelev_setr
+
+!
+! Dump on file: can be fine-tuned to include the (aggregated) matrix
+! as well as smoother and solver. 
+!
+subroutine mld_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
+  use psb_base_mod
+  use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_dump
+  implicit none 
+  class(mld_conelev_type), intent(in) :: lv
+  integer, intent(in)              :: level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: ac, rp, smoother, solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: ac_, rp_
+  !  len of prefix_ 
+
+  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 
+    icontxt = lv%base_desc%get_context()
+    call psb_info(icontxt,iam,np)
+  else 
+    icontxt = -1 
+    iam     = -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
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  if (level >= 2) then 
+    if (ac_) then 
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%ac%print(fname,head=head)
+    end if
+    if (rp_) then 
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%map%map_X2Y%print(fname,head=head)
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%map%map_Y2X%print(fname,head=head)
+    end if
+  end if
+  if (allocated(lv%sm)) &
+       & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver)
+
+end subroutine mld_c_base_onelev_dump
+
+

mlprec/mld_c_onelev_mod.f90

@@ -57,7 +57,7 @@ module mld_c_onelev_mod
   use mld_base_prec_type
   use mld_c_base_smoother_mod
   use psb_base_mod, only : psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
-       & psb_clinmap_type
+       & psb_clinmap_type, psb_spk_, psb_long_int_k_, psb_desc_type
   !
   !
   ! Type: mld_Tonelev_type.
@@ -127,31 +127,112 @@ module mld_c_onelev_mod
     type(psb_desc_type), pointer    :: base_desc => null() 
     type(psb_clinmap_type)          :: map
   contains
-    procedure, pass(lv) :: descr   => c_base_onelev_descr
+    procedure, pass(lv) :: descr   => mld_c_base_onelev_descr
     procedure, pass(lv) :: default => c_base_onelev_default
-    procedure, pass(lv) :: free    => c_base_onelev_free
+    procedure, pass(lv) :: free    => mld_c_base_onelev_free
     procedure, pass(lv) :: nullify => c_base_onelev_nullify
-    procedure, pass(lv) :: check => c_base_onelev_check
+    procedure, pass(lv) :: check => mld_c_base_onelev_check
-    procedure, pass(lv) :: dump  => c_base_onelev_dump
+    procedure, pass(lv) :: dump  => mld_c_base_onelev_dump
-    procedure, pass(lv) :: seti  => c_base_onelev_seti
+    procedure, pass(lv) :: seti  => mld_c_base_onelev_seti
-    procedure, pass(lv) :: setr  => c_base_onelev_setr
+    procedure, pass(lv) :: setr  => mld_c_base_onelev_setr
-    procedure, pass(lv) :: setc  => c_base_onelev_setc
+    procedure, pass(lv) :: setc  => mld_c_base_onelev_setc
     generic, public     :: set   => seti, setr, setc
     procedure, pass(lv) :: sizeof => c_base_onelev_sizeof
     procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros
   end type mld_conelev_type
 
-  private :: c_base_onelev_seti, c_base_onelev_setc, &
+  private :: c_base_onelev_default, c_base_onelev_sizeof, &
-       &  c_base_onelev_setr, c_base_onelev_check, &
+       &  c_base_onelev_nullify, c_base_onelev_get_nzeros
-       &  c_base_onelev_default, c_base_onelev_dump, &
+
-       &  c_base_onelev_descr,  c_base_onelev_sizeof, &
+
-       &  c_base_onelev_free,  c_base_onelev_nullify,&
+
-       &  c_base_onelev_get_nzeros
+  interface mld_c_base_onelev_descr
-
+    subroutine mld_c_base_onelev_descr(lv,il,nl,info,iout)
-
+      import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
-  interface mld_nullify_onelevprec
+           & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type
-    module procedure  mld_nullify_d_onelevprec
+      Implicit None
-  end interface
+      ! Arguments
+      class(mld_conelev_type), intent(in) :: lv
+      integer, intent(in)                 :: il,nl
+      integer, intent(out)                :: info
+      integer, intent(in), optional       :: iout
+    end subroutine mld_c_base_onelev_descr
+  end interface mld_c_base_onelev_descr
+  
+  interface mld_c_base_onelev_free
+    subroutine mld_c_base_onelev_free(lv,info)
+      import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
+           & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type
+      implicit none 
+      
+      class(mld_conelev_type), intent(inout) :: lv
+      integer, intent(out)                :: info
+    end subroutine mld_c_base_onelev_free
+  end interface mld_c_base_onelev_free
+  
+  interface mld_c_base_onelev_check
+    subroutine mld_c_base_onelev_check(lv,info)
+      import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
+           & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      ! Arguments
+      class(mld_conelev_type), intent(inout) :: lv 
+      integer, intent(out)                   :: info
+    end subroutine mld_c_base_onelev_check
+  end interface mld_c_base_onelev_check
+  
+  interface mld_c_base_onelev_seti
+    subroutine mld_c_base_onelev_seti(lv,what,val,info)
+      import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
+           & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_conelev_type), intent(inout) :: lv 
+      integer, intent(in)                          :: what 
+      integer, intent(in)                          :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_c_base_onelev_seti
+  end interface mld_c_base_onelev_seti
+  
+  interface mld_c_base_onelev_setc
+    subroutine mld_c_base_onelev_setc(lv,what,val,info)
+      import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
+           & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      ! Arguments
+      class(mld_conelev_type), intent(inout) :: lv 
+      integer, intent(in)                            :: what 
+      character(len=*), intent(in)                   :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_c_base_onelev_setc
+  end interface mld_c_base_onelev_setc
+  
+  interface mld_c_base_onelev_setr
+    subroutine mld_c_base_onelev_setr(lv,what,val,info)
+      import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
+           & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      
+      class(mld_conelev_type), intent(inout) :: lv 
+      integer, intent(in)                            :: what 
+      real(psb_spk_), intent(in)                     :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_c_base_onelev_setr
+  end interface mld_c_base_onelev_setr
+
+  interface mld_c_base_onelev_dump
+    subroutine mld_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
+      import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
+           & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type
+      implicit none 
+      class(mld_conelev_type), intent(in) :: lv
+      integer, intent(in)              :: level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: ac, rp, smoother, solver
+    end subroutine mld_c_base_onelev_dump
+  end interface mld_c_base_onelev_dump
   
   
 contains
@@ -184,137 +265,6 @@ contains
   end function c_base_onelev_sizeof
 
 
-  !
-  ! Subroutine: mld_file_onelev_descr
-  ! Version: complex
-  !
-  !  This routine prints a description of the preconditioner to the standard 
-  !  output or to a file. It must be called after the preconditioner has been
-  !  built by mld_precbld.
-  !
-  ! Arguments:
-  !  p       -  type(mld_Tprec_type), input.
-  !             The preconditioner data structure to be printed out.
-  !  info    -  integer, output.
-  !             error code.
-  !  iout    -  integer, input, optional.
-  !             The id of the file where the preconditioner description
-  !             will be printed. If iout is not present, then the standard
-  !             output is condidered.
-  !
-  subroutine c_base_onelev_descr(lv,il,nl,info,iout)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_conelev_type), intent(in) :: lv
-    integer, intent(in)                 :: il,nl
-    integer, intent(out)                :: info
-    integer, intent(in), optional       :: iout
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_c_base_onelev_descr'
-    integer      :: iout_
-    logical      :: coarse
-
-
-    call psb_erractionsave(err_act)
-
-
-    coarse = (il==nl)
-
-    if (present(iout)) then 
-      iout_ = iout
-    else 
-      iout_ = 6
-    end if
-    
-    write(iout_,*) 
-    if (il == 2) then 
-      call lv%parms%mldescr(iout_,info)
-      write(iout_,*) 
-    end if
-
-    if (coarse)  then 
-      write(iout_,*) ' Level ',il,' (coarsest)'
-    else
-      write(iout_,*) ' Level ',il
-    end if
-
-    call lv%parms%descr(iout_,info,coarse=coarse)
-        
-    if (nl > 1) then 
-      if (allocated(lv%map%naggr)) then
-        write(iout_,*) '  Size of coarse matrix: ', &
-             &  sum(lv%map%naggr(:))
-        write(iout_,*) '  Sizes of aggregates: ', &
-             &  lv%map%naggr(:)
-      end if
-    end if
-
-    if (coarse.and.allocated(lv%sm)) &
-         & call lv%sm%descr(info,iout=iout_,coarse=coarse)
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_onelev_descr
-
-
-  !
-  ! Subroutines: mld_T_onelev_precfree
-  ! Version: complex
-  !
-  !  These routines deallocate the mld_Tonelev_type 
-  !
-  ! Arguments:
-  !  p       -  type(mld_Tonelev_type), input.
-  !             The data structure to be deallocated.
-  !  info    -  integer, output.
-  !             error code.
-  !
-  subroutine c_base_onelev_free(lv,info)
-    use psb_base_mod
-    implicit none 
-
-    class(mld_conelev_type), intent(inout) :: lv
-    integer, intent(out)                :: info
-    integer :: i
-
-    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. 
-    call lv%sm%free(info)
-    
-    call lv%ac%free()
-    if (psb_is_ok_desc(lv%desc_ac)) &
-         & call psb_cdfree(lv%desc_ac,info)
-    call lv%map%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) 
-
-    call lv%nullify()
-
-  end subroutine c_base_onelev_free
-
-
   subroutine c_base_onelev_nullify(lv)
     implicit none 
 
@@ -325,69 +275,6 @@ contains
 
   end subroutine c_base_onelev_nullify
 
-
-  subroutine mld_nullify_d_onelevprec(p)
-    implicit none 
-
-    type(mld_conelev_type), intent(inout) :: p
-
-    nullify(p%base_a) 
-    nullify(p%base_desc) 
-
-  end subroutine mld_nullify_d_onelevprec
-
-  !
-  ! Onelevel checks. 
-  ! The number of Jacobi sweeps to be applied is not
-  ! tied to the Jacobi smoother: logically, you have
-  ! a smoother and you can choose to apply it any number
-  ! of times you like. 
-  !
-  subroutine c_base_onelev_check(lv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_conelev_type), intent(inout) :: lv 
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    call mld_check_def(lv%parms%sweeps,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-    call mld_check_def(lv%parms%sweeps_pre,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-    call mld_check_def(lv%parms%sweeps_post,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-
-    
-    if (allocated(lv%sm)) then 
-      call lv%sm%check(info)
-    else 
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_onelev_check
-
   !
   ! Multilevel defaults: 
   !  multiplicative vs. additive ML framework;
@@ -400,8 +287,6 @@ contains
 
   subroutine c_base_onelev_default(lv)
 
-    use psb_base_mod
-
     Implicit None
 
     ! Arguments
@@ -427,241 +312,4 @@ contains
 
   end subroutine c_base_onelev_default
 
-  ! 
-  ! Set routines:
-  ! Parameters belonging here are:
-  !   Number of smoothing sweeps;
-  !   Smoother position;
-  !   Aggregation related parameters
-  !   Record request on coarse level solver,
-  !    for checks on solver vs. smoother nomenclature
-  !    reconciliation. 
-  ! 
-  subroutine c_base_onelev_seti(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_conelev_type), intent(inout) :: lv 
-    integer, intent(in)                          :: what 
-    integer, intent(in)                          :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_seti'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    select case (what) 
-
-    case (mld_smoother_sweeps_)
-      lv%parms%sweeps      = val
-      lv%parms%sweeps_pre  = val
-      lv%parms%sweeps_post = val
-
-    case (mld_smoother_sweeps_pre_)
-      lv%parms%sweeps_pre  = val
-
-    case (mld_smoother_sweeps_post_)
-      lv%parms%sweeps_post = val
-
-    case (mld_ml_type_)
-      lv%parms%ml_type       = val
-
-    case (mld_aggr_alg_)
-      lv%parms%aggr_alg      = val
-
-    case (mld_aggr_kind_)
-      lv%parms%aggr_kind     = val
-
-    case (mld_coarse_mat_)
-      lv%parms%coarse_mat    = val
-
-    case (mld_smoother_pos_)
-      lv%parms%smoother_pos  = val
-
-    case (mld_aggr_omega_alg_)
-      lv%parms%aggr_omega_alg= val
-
-    case (mld_aggr_eig_)
-      lv%parms%aggr_eig      = val
-
-    case (mld_aggr_filter_)
-      lv%parms%aggr_filter   = val
-
-    case (mld_coarse_solve_)
-      lv%parms%coarse_solve    = val
-
-    case default
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info)
-      end if
-      if (info /= psb_success_) goto 9999
-    end select
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_onelev_seti
-
-  subroutine c_base_onelev_setc(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_conelev_type), intent(inout) :: lv 
-    integer, intent(in)                            :: what 
-    character(len=*), intent(in)                   :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_setc'
-    integer :: ival 
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    call mld_stringval(val,ival,info)
-    if (info == psb_success_) call lv%set(what,ival,info)
-
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_onelev_setc
-  
-  subroutine c_base_onelev_setr(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_conelev_type), intent(inout) :: lv 
-    integer, intent(in)                            :: what 
-    real(psb_spk_), intent(in)                     :: val
-    integer, intent(out)                           :: info
-    Integer :: err_act
-    character(len=20)  :: name='d_base_onelev_setr'
-
-    call psb_erractionsave(err_act)
-
-
-    info = psb_success_
-    
-    select case (what) 
-
-    case (mld_aggr_omega_val_)
-      lv%parms%aggr_omega_val= val
-   
-    case (mld_aggr_thresh_)
-      lv%parms%aggr_thresh   = val
-
-    case default
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info)
-      end if
-      if (info /= psb_success_) goto 9999
-    end select
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine c_base_onelev_setr
-
-  !
-  ! Dump on file: can be fine-tuned to include the (aggregated) matrix
-  ! as well as smoother and solver. 
-  !
-  subroutine c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_conelev_type), intent(in) :: lv
-    integer, intent(in)              :: level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: ac, rp, smoother, solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: ac_, rp_
-    !  len of prefix_ 
-
-    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 
-      icontxt = lv%base_desc%get_context()
-      call psb_info(icontxt,iam,np)
-    else 
-      icontxt = -1 
-      iam     = -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
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    if (level >= 2) then 
-      if (ac_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%ac%print(fname,head=head)
-      end if
-      if (rp_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%map%map_X2Y%print(fname,head=head)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%map%map_Y2X%print(fname,head=head)
-      end if
-    end if
-    if (allocated(lv%sm)) &
-         & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver)
-
-  end subroutine c_base_onelev_dump
-
-
 end module mld_c_onelev_mod

mlprec/mld_d_base_smoother_impl.f90

@@ -0,0 +1,481 @@
+!!$
+!!$ 
+!!$                           MLD2P4  version 2.0
+!!$  MultiLevel Domain Decomposition Parallel Preconditioners Package
+!!$             based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!!$  
+!!$  (C) Copyright 2008,2009,2010
+!!$
+!!$                      Salvatore Filippone  University of Rome Tor Vergata
+!!$                      Alfredo Buttari      CNRS-IRIT, Toulouse
+!!$                      Pasqua D'Ambra       ICAR-CNR, Naples
+!!$                      Daniela di Serafino  Second University of Naples
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the MLD2P4 group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 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.
+!!$ 
+!!$
+
+!
+! Apply: comes in two versions, on plain arrays or on encapsulated
+! vectors.
+! This basic version just applies the local solver, whatever that
+! is. 
+!
+
+subroutine mld_d_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name =>  mld_d_base_smoother_apply
+  implicit none 
+  type(psb_desc_type), intent(in)             :: desc_data
+  class(mld_d_base_smoother_type), intent(in) :: 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, intent(in)                         :: sweeps
+  real(psb_dpk_),target, intent(inout)        :: work(:)
+  integer, intent(out)                        :: info
+
+  Integer           :: err_act
+  character(len=20) :: name='d_base_smoother_apply'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
+  else
+    info = 1121
+  endif
+  if (info /= psb_success_) then 
+    call psb_errpush(info,name)
+    goto 9999 
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_d_base_smoother_apply
+
+subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
+     &  trans,sweeps,work,info)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name =>  mld_d_base_smoother_apply_vect
+  implicit none 
+  type(psb_desc_type), intent(in)                :: desc_data
+  class(mld_d_base_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, intent(in)                            :: sweeps
+  real(psb_dpk_),target, intent(inout)           :: work(:)
+  integer, intent(out)                           :: info
+
+  Integer           :: err_act
+  character(len=20) :: name='d_base_smoother_apply'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
+  else
+    info = 1121
+  endif
+  if (info /= psb_success_) then 
+    call psb_errpush(info,name)
+    goto 9999 
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_d_base_smoother_apply_vect
+
+!
+! Check:
+! 1. Check that we do have a solver object
+! 2. Call its check method
+!
+
+subroutine mld_d_base_smoother_check(sm,info)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name =>  mld_d_base_smoother_check
+  Implicit None
+
+  ! Arguments
+  class(mld_d_base_smoother_type), intent(inout) :: sm 
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_smoother_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%check(info)
+  else 
+    info=3111
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_smoother_check
+
+!
+! Set methods: the come in multiple versions according
+! to whether we are setting with integer, real or character
+! input.
+! The basic rule is: if the input refers to a parameter
+! of the smoother, use it, otherwise pass it to the
+! solver object for further processing.
+! Since there are no parameters in the base smoother
+! we just pass everything to the solver object. 
+!
+subroutine mld_d_base_smoother_seti(sm,what,val,info)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name =>  mld_d_base_smoother_seti
+  Implicit None
+  ! Arguments
+  class(mld_d_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  integer, intent(in)                            :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_smoother_seti'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_smoother_seti
+
+subroutine mld_d_base_smoother_setc(sm,what,val,info)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name =>  mld_d_base_smoother_setc
+  Implicit None
+
+  ! Arguments
+  class(mld_d_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  character(len=*), intent(in)                   :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_smoother_setc'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_smoother_setc
+
+subroutine mld_d_base_smoother_setr(sm,what,val,info)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name =>  mld_d_base_smoother_setr
+  Implicit None
+
+  ! Arguments
+  class(mld_d_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  real(psb_dpk_), intent(in)                     :: val
+  integer, intent(out)                           :: info
+  Integer :: err_act
+  character(len=20)  :: name='d_base_smoother_setr'
+
+  call psb_erractionsave(err_act)
+
+
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_smoother_setr
+
+
+!
+! Build method.
+! At base level we only have to pass data to the inner solver. 
+! AMOLD/VMOLD allow to have any relevant sparse matrix or vector
+! to be stored in a given format. This is essential e.g.
+! when dealing  with GPUs. 
+!
+subroutine mld_d_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name =>  mld_d_base_smoother_bld
+  Implicit None
+
+  ! Arguments
+  type(psb_dspmat_type), intent(in), target      :: a
+  Type(psb_desc_type), Intent(in)                :: desc_a 
+  class(mld_d_base_smoother_type), intent(inout) :: sm 
+  character, intent(in)                          :: upd
+  integer, intent(out)                           :: info
+  class(psb_d_base_sparse_mat), intent(in), optional :: amold
+  class(psb_d_base_vect_type), intent(in), optional  :: vmold
+  Integer           :: err_act
+  character(len=20) :: name='d_base_smoother_bld'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%build(a,desc_a,upd,info,amold=amold,vmold=vmold)
+  else
+    info = 1121
+    call psb_errpush(info,name)
+  endif
+  if (info /= psb_success_) goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_smoother_bld
+
+!
+! Free method (aka destructor).
+! In most cases we could do without; however
+! for cases where there are data objects allocated outside
+! of the Fortran RTE we need to free them explicitly.
+!
+! Even in that case, we could do without this if FINAL
+! subroutines were supported, which is not the case
+
+! in GNU Fortran up to 4.7. 
+!
+subroutine mld_d_base_smoother_free(sm,info)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name => s
+  Implicit None
+
+  ! Arguments
+  class(mld_d_base_smoother_type), intent(inout) :: sm
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_smoother_free'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%free(info)
+  end if
+  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
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_smoother_free
+
+!
+! Print a description
+!
+
+subroutine mld_d_base_smoother_descr(sm,info,iout,coarse)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name =>  mld_d_base_smoother_descr
+  Implicit None
+
+  ! Arguments
+  class(mld_d_base_smoother_type), intent(in) :: sm
+  integer, intent(out)                        :: info
+  integer, intent(in), optional               :: iout
+  logical, intent(in), optional               :: coarse
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_d_base_smoother_descr'
+  integer :: iout_
+  logical      :: coarse_
+
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (present(coarse)) then 
+    coarse_ = coarse
+  else
+    coarse_ = .false.
+  end if
+  if (present(iout)) then 
+    iout_ = iout
+  else 
+    iout_ = 6
+  end if
+
+  if (.not.coarse_) &
+       &  write(iout_,*) 'Base smoother with local solver'
+  if (allocated(sm%sv)) then 
+    call sm%sv%descr(info,iout,coarse)
+    if (info /= psb_success_) then 
+      info = psb_err_from_subroutine_ 
+      call psb_errpush(info,name,a_err='Local solver')
+      goto 9999
+    end if
+  end if
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_smoother_descr
+
+!
+! Dump 
+! to file, for debugging purposes.
+!
+subroutine mld_d_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+  use psb_base_mod
+  use mld_d_base_smoother_mod, mld_protect_name =>  mld_d_base_smoother_dmp
+  implicit none 
+  class(mld_d_base_smoother_type), intent(in) :: sm
+  integer, intent(in)              :: ictxt,level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: smoother, solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: smoother_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_smth_d"
+  end if
+
+  call psb_info(ictxt,iam,np)
+
+  if (present(smoother)) then 
+    smoother_ = smoother
+  else
+    smoother_ = .false. 
+  end if
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  ! At base level do nothing for the smoother
+  if (allocated(sm%sv)) &
+       & call sm%sv%dump(ictxt,level,info,solver=solver)
+
+end subroutine mld_d_base_smoother_dmp
+

mlprec/mld_d_base_smoother_mod.f90

@@ -54,7 +54,8 @@
 module mld_d_base_smoother_mod
 
   use mld_d_base_solver_mod
-  use psb_base_mod, only : psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type
+  use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_long_int_k_,&
+       & psb_d_vect_type, psb_d_base_vect_type, psb_d_base_sparse_mat, psb_dpk_
   
   !
   !
@@ -91,32 +92,155 @@ module mld_d_base_smoother_mod
   type  mld_d_base_smoother_type
     class(mld_d_base_solver_type), allocatable :: sv
   contains
-    procedure, pass(sm) :: check => d_base_smoother_check
+    procedure, pass(sm) :: check => mld_d_base_smoother_check
-    procedure, pass(sm) :: dump  => d_base_smoother_dmp
+    procedure, pass(sm) :: dump  => mld_d_base_smoother_dmp
-    procedure, pass(sm) :: build => d_base_smoother_bld
+    procedure, pass(sm) :: build => mld_d_base_smoother_bld
-    procedure, pass(sm) :: apply_v => d_base_smoother_apply_vect
+    procedure, pass(sm) :: apply_v => mld_d_base_smoother_apply_vect
-    procedure, pass(sm) :: apply_a => d_base_smoother_apply
+    procedure, pass(sm) :: apply_a => mld_d_base_smoother_apply
     generic, public     :: apply => apply_a, apply_v
-    procedure, pass(sm) :: free  => d_base_smoother_free
+    procedure, pass(sm) :: free  => mld_d_base_smoother_free
-    procedure, pass(sm) :: seti  => d_base_smoother_seti
+    procedure, pass(sm) :: seti  => mld_d_base_smoother_seti
-    procedure, pass(sm) :: setc  => d_base_smoother_setc
+    procedure, pass(sm) :: setc  => mld_d_base_smoother_setc
-    procedure, pass(sm) :: setr  => d_base_smoother_setr
+    procedure, pass(sm) :: setr  => mld_d_base_smoother_setr
     generic, public     :: set   => seti, setc, setr
     procedure, pass(sm) :: default => d_base_smoother_default
-    procedure, pass(sm) :: descr =>   d_base_smoother_descr
+    procedure, pass(sm) :: descr =>   mld_d_base_smoother_descr
     procedure, pass(sm) :: sizeof =>  d_base_smoother_sizeof
     procedure, pass(sm) :: get_nzeros => d_base_smoother_get_nzeros
   end type mld_d_base_smoother_type
 
 
-  private :: d_base_smoother_bld,   d_base_smoother_apply, &
+  private :: d_base_smoother_sizeof, &
-       &  d_base_smoother_free,  d_base_smoother_seti, &
+       &  d_base_smoother_default, d_base_smoother_get_nzeros
-       &  d_base_smoother_setc,  d_base_smoother_setr,&
+
-       &  d_base_smoother_descr, d_base_smoother_sizeof, &
+
-       &  d_base_smoother_default, d_base_smoother_check, &
+
-       &  d_base_smoother_dmp, d_base_smoother_apply_vect, &
+  interface mld_d_base_smoother_apply
-       &  d_base_smoother_get_nzeros
+    subroutine mld_d_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
-
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+       & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      type(psb_desc_type), intent(in)             :: desc_data
+      class(mld_d_base_smoother_type), intent(in) :: 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, intent(in)                         :: sweeps
+      real(psb_dpk_),target, intent(inout)        :: work(:)
+      integer, intent(out)                        :: info
+    end subroutine mld_d_base_smoother_apply
+  end interface mld_d_base_smoother_apply
+  
+  interface mld_d_base_smoother_apply_vect
+    subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
+         &  trans,sweeps,work,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      type(psb_desc_type), intent(in)                :: desc_data
+      class(mld_d_base_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, intent(in)                            :: sweeps
+      real(psb_dpk_),target, intent(inout)           :: work(:)
+      integer, intent(out)                           :: info
+    end subroutine mld_d_base_smoother_apply_vect
+  end interface mld_d_base_smoother_apply_vect
+  
+  interface mld_d_base_smoother_check
+    subroutine mld_d_base_smoother_check(sm,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      ! Arguments
+      class(mld_d_base_smoother_type), intent(inout) :: sm 
+      integer, intent(out)                   :: info
+    end subroutine mld_d_base_smoother_check
+  end interface mld_d_base_smoother_check
+  
+  interface mld_d_base_smoother_seti
+    subroutine mld_d_base_smoother_seti(sm,what,val,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      ! Arguments
+      class(mld_d_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      integer, intent(in)                            :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_d_base_smoother_seti
+  end interface mld_d_base_smoother_seti
+  
+  interface mld_d_base_smoother_setc
+    subroutine mld_d_base_smoother_setc(sm,what,val,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      class(mld_d_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      character(len=*), intent(in)                   :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_d_base_smoother_setc
+  end interface mld_d_base_smoother_setc
+  
+  interface mld_d_base_smoother_setr
+    subroutine mld_d_base_smoother_setr(sm,what,val,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      ! Arguments
+      class(mld_d_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      real(psb_dpk_), intent(in)                     :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_d_base_smoother_setr
+  end interface mld_d_base_smoother_setr
+  
+  interface mld_d_base_smoother_bld
+    subroutine mld_d_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      ! Arguments
+      type(psb_dspmat_type), intent(in), target      :: a
+      Type(psb_desc_type), Intent(in)                :: desc_a 
+      class(mld_d_base_smoother_type), intent(inout) :: sm 
+      character, intent(in)                          :: upd
+      integer, intent(out)                           :: info
+      class(psb_d_base_sparse_mat), intent(in), optional :: amold
+      class(psb_d_base_vect_type), intent(in), optional  :: vmold
+    end subroutine mld_d_base_smoother_bld
+  end interface mld_d_base_smoother_bld
+  
+  interface mld_d_base_smoother_free
+    subroutine mld_d_base_smoother_free(sm,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      ! Arguments
+      class(mld_d_base_smoother_type), intent(inout) :: sm
+      integer, intent(out)                           :: info
+    end subroutine mld_d_base_smoother_free
+  end interface mld_d_base_smoother_free
+  
+  interface mld_d_base_smoother_descr
+    subroutine mld_d_base_smoother_descr(sm,info,iout,coarse)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      ! Arguments
+      class(mld_d_base_smoother_type), intent(in) :: sm
+      integer, intent(out)                        :: info
+      integer, intent(in), optional               :: iout
+      logical, intent(in), optional               :: coarse
+    end subroutine mld_d_base_smoother_descr
+  end interface mld_d_base_smoother_descr
+  
+  interface mld_d_base_smoother_dmp
+    subroutine mld_d_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_smoother_type
+      class(mld_d_base_smoother_type), intent(in) :: sm
+      integer, intent(in)              :: ictxt,level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: smoother, solver
+    end subroutine mld_d_base_smoother_dmp
+  end interface mld_d_base_smoother_dmp
   
 contains
   !
@@ -149,451 +273,6 @@ contains
     return
   end function d_base_smoother_sizeof
 
-
-  !
-  ! Apply: comes in two versions, on plain arrays or on encapsulated
-  ! vectors.
-  ! This basic version just applies the local solver, whatever that
-  ! is. 
-  !
-
-  subroutine d_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)             :: desc_data
-    class(mld_d_base_smoother_type), intent(in) :: 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, intent(in)                         :: sweeps
-    real(psb_dpk_),target, intent(inout)        :: work(:)
-    integer, intent(out)                        :: info
-    
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_apply'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
-    else
-      info = 1121
-    endif
-    if (info /= psb_success_) then 
-      call psb_errpush(info,name)
-      goto 9999 
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine d_base_smoother_apply
-
-  subroutine d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
-       &  trans,sweeps,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)                :: desc_data
-    class(mld_d_base_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, intent(in)                            :: sweeps
-    real(psb_dpk_),target, intent(inout)           :: work(:)
-    integer, intent(out)                           :: info
-    
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_apply'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
-    else
-      info = 1121
-    endif
-    if (info /= psb_success_) then 
-      call psb_errpush(info,name)
-      goto 9999 
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine d_base_smoother_apply_vect
-
-  !
-  ! Check:
-  ! 1. Check that we do have a solver object
-  ! 2. Call its check method
-  !
-
-  subroutine d_base_smoother_check(sm,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_smoother_type), intent(inout) :: sm 
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%check(info)
-    else 
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_smoother_check
-
-  !
-  ! Set methods: the come in multiple versions according
-  ! to whether we are setting with integer, real or character
-  ! input.
-  ! The basic rule is: if the input refers to a parameter
-  ! of the smoother, use it, otherwise pass it to the
-  ! solver object for further processing.
-  ! Since there are no parameters in the base smoother
-  ! we just pass everything to the solver object. 
-  !
-  subroutine d_base_smoother_seti(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    integer, intent(in)                            :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_seti'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_smoother_seti
-
-  subroutine d_base_smoother_setc(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    character(len=*), intent(in)                   :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_setc'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_smoother_setc
-  
-  subroutine d_base_smoother_setr(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    real(psb_dpk_), intent(in)                     :: val
-    integer, intent(out)                           :: info
-    Integer :: err_act
-    character(len=20)  :: name='d_base_smoother_setr'
-
-    call psb_erractionsave(err_act)
-
-
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_smoother_setr
-
-
-  !
-  ! Build method.
-  ! At base level we only have to pass data to the inner solver. 
-  ! AMOLD/VMOLD allow to have any relevant sparse matrix or vector
-  ! to be stored in a given format. This is essential e.g.
-  ! when dealing  with GPUs. 
-  !
-  subroutine d_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    type(psb_dspmat_type), intent(in), target      :: a
-    Type(psb_desc_type), Intent(in)                :: desc_a 
-    class(mld_d_base_smoother_type), intent(inout) :: sm 
-    character, intent(in)                          :: upd
-    integer, intent(out)                           :: info
-    class(psb_d_base_sparse_mat), intent(in), optional :: amold
-    class(psb_d_base_vect_type), intent(in), optional  :: vmold
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_bld'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%build(a,desc_a,upd,info,amold=amold,vmold=vmold)
-    else
-      info = 1121
-      call psb_errpush(info,name)
-    endif
-    if (info /= psb_success_) goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_smoother_bld
-
-  !
-  ! Free method (aka destructor).
-  ! In most cases we could do without; however
-  ! for cases where there are data objects allocated outside
-  ! of the Fortran RTE we need to free them explicitly.
-  !
-  ! Even in that case, we could do without this if FINAL
-  ! subroutines were supported, which is not the case
-  ! in GNU Fortran up to 4.7. 
-  !
-  subroutine d_base_smoother_free(sm,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_smoother_type), intent(inout) :: sm
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_free'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    
-    if (allocated(sm%sv)) then 
-      call sm%sv%free(info)
-    end if
-    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
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_smoother_free
-
-  !
-  ! Print a description
-  !
-
-  subroutine d_base_smoother_descr(sm,info,iout,coarse)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_smoother_type), intent(in) :: sm
-    integer, intent(out)                        :: info
-    integer, intent(in), optional               :: iout
-    logical, intent(in), optional               :: coarse
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_d_base_smoother_descr'
-    integer :: iout_
-    logical      :: coarse_
-
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (present(coarse)) then 
-      coarse_ = coarse
-    else
-      coarse_ = .false.
-    end if
-    if (present(iout)) then 
-      iout_ = iout
-    else 
-      iout_ = 6
-    end if
-
-    if (.not.coarse_) &
-         &  write(iout_,*) 'Base smoother with local solver'
-    if (allocated(sm%sv)) then 
-      call sm%sv%descr(info,iout,coarse)
-      if (info /= psb_success_) then 
-        info = psb_err_from_subroutine_ 
-        call psb_errpush(info,name,a_err='Local solver')
-        goto 9999
-      end if
-    end if
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_smoother_descr
-
-  !
-  ! Dump 
-  ! to file, for debugging purposes.
-  !
-  subroutine d_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_d_base_smoother_type), intent(in) :: sm
-    integer, intent(in)              :: ictxt,level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: smoother, solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: smoother_
-    !  len of prefix_ 
-
-    info = 0
-
-    if (present(prefix)) then 
-      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-    else
-      prefix_ = "dump_smth_d"
-    end if
-
-    call psb_info(ictxt,iam,np)
-
-    if (present(smoother)) then 
-      smoother_ = smoother
-    else
-      smoother_ = .false. 
-    end if
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    ! At base level do nothing for the smoother
-    if (allocated(sm%sv)) &
-         & call sm%sv%dump(ictxt,level,info,solver=solver)
-
-  end subroutine d_base_smoother_dmp
-
   !
   ! Set sensible defaults.
   ! To be called immediately after allocation
@@ -610,5 +289,4 @@ contains
   end subroutine d_base_smoother_default
 
 
-
 end module mld_d_base_smoother_mod

mlprec/mld_d_base_solver_impl.f90

@@ -0,0 +1,338 @@
+!
+! Apply: comes in two versions, on plain arrays or on encapsulated
+! vectors.
+! The base version throws an error, since it means that no explicit
+! choice was made. 
+! Question: would it make sense to transform the base version into
+! the ID version, i.e. "base_solver" is the identity operator? 
+! 
+
+subroutine mld_d_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_apply
+  implicit none 
+  type(psb_desc_type), intent(in)           :: desc_data
+  class(mld_d_base_solver_type), intent(in) :: sv
+  real(psb_dpk_),intent(inout)              :: x(:)
+  real(psb_dpk_),intent(inout)              :: y(:)
+  real(psb_dpk_),intent(in)                 :: alpha,beta
+  character(len=1),intent(in)               :: trans
+  real(psb_dpk_),target, intent(inout)      :: work(:)
+  integer, intent(out)                      :: info
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_d_base_solver_apply
+
+subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_apply_vect
+  implicit none 
+  type(psb_desc_type), intent(in)              :: desc_data
+  class(mld_d_base_solver_type), intent(inout) :: sv
+  type(psb_d_vect_type),intent(inout)          :: x
+  type(psb_d_vect_type),intent(inout)          :: y
+  real(psb_dpk_),intent(in)                    :: alpha,beta
+  character(len=1),intent(in)                  :: trans
+  real(psb_dpk_),target, intent(inout)         :: work(:)
+  integer, intent(out)                         :: info
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_d_base_solver_apply_vect
+
+
+!
+! Build
+! The base version throws an error, since it means that no explicit
+! choice was made. 
+!
+subroutine mld_d_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_bld
+  Implicit None
+  ! Arguments
+  type(psb_dspmat_type), intent(in), target           :: a
+  Type(psb_desc_type), Intent(in)                     :: desc_a 
+  class(mld_d_base_solver_type), intent(inout)        :: sv
+  character, intent(in)                               :: upd
+  integer, intent(out)                                :: info
+  type(psb_dspmat_type), intent(in), target, optional :: b
+  class(psb_d_base_sparse_mat), intent(in), optional  :: amold
+  class(psb_d_base_vect_type), intent(in), optional   :: vmold
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_bld'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_solver_bld
+
+subroutine mld_d_base_solver_check(sv,info)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_check
+  Implicit None
+  ! Arguments
+  class(mld_d_base_solver_type), intent(inout) :: sv
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_solver_check
+
+!
+! Set.
+! The base version does nothing; the principle is that
+! SET acts on what is known, and delegates what is unknown.
+! Since we are at the bottom of the hierarchy, there's no one
+! to delegate, so we do nothing. 
+!
+subroutine mld_d_base_solver_seti(sv,what,val,info)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_seti
+  Implicit None
+  ! Arguments
+  class(mld_d_base_solver_type), intent(inout) :: sv 
+  integer, intent(in)                          :: what 
+  integer, intent(in)                          :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_seti'
+
+  ! Correct action here is doing nothing. 
+  info = 0
+
+  return
+end subroutine mld_d_base_solver_seti
+
+subroutine mld_d_base_solver_setc(sv,what,val,info)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_setc
+  Implicit None
+  ! Arguments
+  class(mld_d_base_solver_type), intent(inout) :: sv
+  integer, intent(in)                          :: what 
+  character(len=*), intent(in)                 :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act, ival 
+  character(len=20) :: name='d_base_solver_setc'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  call mld_stringval(val,ival,info)
+  if (info == psb_success_) call sv%set(what,ival,info)
+
+  if (info /= psb_success_) goto 9999
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_solver_setc
+
+subroutine mld_d_base_solver_setr(sv,what,val,info)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_setr
+  Implicit None
+  ! Arguments
+  class(mld_d_base_solver_type), intent(inout) :: sv 
+  integer, intent(in)                          :: what 
+  real(psb_dpk_), intent(in)                   :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_setr'
+
+
+  ! Correct action here is doing nothing. 
+  info = 0
+
+  return
+end subroutine mld_d_base_solver_setr
+
+!
+! Free
+! The base version throws an error, since it means that no explicit
+! choice was made. IS THIS CORRECT? I suspect it would be better
+! to be silent here, to cover reallocation. 
+!
+subroutine mld_d_base_solver_free(sv,info)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_free
+  Implicit None
+  ! Arguments
+  class(mld_d_base_solver_type), intent(inout) :: sv
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_free'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_solver_free
+
+subroutine mld_d_base_solver_descr(sv,info,iout,coarse)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_descr
+  Implicit None
+  ! Arguments
+  class(mld_d_base_solver_type), intent(in) :: sv
+  integer, intent(out)                      :: info
+  integer, intent(in), optional             :: iout
+  logical, intent(in), optional             :: coarse
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_d_base_solver_descr'
+  integer      :: iout_
+
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_solver_descr
+
+!
+! Dump. For debugging purposes. 
+!
+subroutine mld_d_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
+  use psb_base_mod
+  use mld_d_base_solver_mod, mld_protect_name =>  mld_d_base_solver_dmp
+  implicit none 
+  class(mld_d_base_solver_type), intent(in) :: sv
+  integer, intent(in)              :: ictxt,level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: solver_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_slv_d"
+  end if
+
+  call psb_info(ictxt,iam,np)
+
+  if (present(solver)) then 
+    solver_ = solver
+  else
+    solver_ = .false. 
+  end if
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  ! At base level do nothing for the solver
+
+end subroutine mld_d_base_solver_dmp
+

mlprec/mld_d_base_solver_mod.f90

@@ -54,7 +54,8 @@
 module mld_d_base_solver_mod
 
   use mld_base_prec_type
-  use psb_base_mod, only : psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type
+  use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_long_int_k_, &
+       & psb_d_vect_type, psb_d_base_vect_type, psb_d_base_sparse_mat, psb_dpk_
   !
   ! 
   ! Type: mld_T_base_solver_type.
@@ -83,32 +84,179 @@ module mld_d_base_solver_mod
 
   type mld_d_base_solver_type
   contains
-    procedure, pass(sv) :: check => d_base_solver_check
+    procedure, pass(sv) :: check => mld_d_base_solver_check
-    procedure, pass(sv) :: dump  => d_base_solver_dmp
+    procedure, pass(sv) :: dump  => mld_d_base_solver_dmp
-    procedure, pass(sv) :: build => d_base_solver_bld
+    procedure, pass(sv) :: build => mld_d_base_solver_bld
-    procedure, pass(sv) :: apply_v => d_base_solver_apply_vect
+    procedure, pass(sv) :: apply_v => mld_d_base_solver_apply_vect
-    procedure, pass(sv) :: apply_a => d_base_solver_apply
+    procedure, pass(sv) :: apply_a => mld_d_base_solver_apply
     generic, public     :: apply => apply_a, apply_v
-    procedure, pass(sv) :: free  => d_base_solver_free
+    procedure, pass(sv) :: free  => mld_d_base_solver_free
-    procedure, pass(sv) :: seti  => d_base_solver_seti
+    procedure, pass(sv) :: seti  => mld_d_base_solver_seti
-    procedure, pass(sv) :: setc  => d_base_solver_setc
+    procedure, pass(sv) :: setc  => mld_d_base_solver_setc
-    procedure, pass(sv) :: setr  => d_base_solver_setr
+    procedure, pass(sv) :: setr  => mld_d_base_solver_setr
     generic, public     :: set   => seti, setc, setr
     procedure, pass(sv) :: default => d_base_solver_default
-    procedure, pass(sv) :: descr   => d_base_solver_descr
+    procedure, pass(sv) :: descr   => mld_d_base_solver_descr
     procedure, pass(sv) :: sizeof  => d_base_solver_sizeof
     procedure, pass(sv) :: get_nzeros => d_base_solver_get_nzeros
   end type mld_d_base_solver_type
 
-  private :: d_base_solver_bld,  d_base_solver_apply, &
+  private :: d_base_solver_sizeof, d_base_solver_default,&
-       &  d_base_solver_free,    d_base_solver_seti, &
-       &  d_base_solver_setc,    d_base_solver_setr, &
-       &  d_base_solver_descr,   d_base_solver_sizeof, &
-       &  d_base_solver_default, d_base_solver_check,&
-       &  d_base_solver_dmp, d_base_solver_apply_vect, &
        &  d_base_solver_get_nzeros
 
 
+  interface  mld_d_base_solver_apply
+    subroutine mld_d_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+       & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+      type(psb_desc_type), intent(in)           :: desc_data
+      class(mld_d_base_solver_type), intent(in) :: sv
+      real(psb_dpk_),intent(inout)              :: x(:)
+      real(psb_dpk_),intent(inout)              :: y(:)
+      real(psb_dpk_),intent(in)                 :: alpha,beta
+      character(len=1),intent(in)               :: trans
+      real(psb_dpk_),target, intent(inout)      :: work(:)
+      integer, intent(out)                      :: info
+    end subroutine mld_d_base_solver_apply
+  end interface mld_d_base_solver_apply
+  
+      
+  interface mld_d_base_solver_apply_vect
+    subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+      
+      type(psb_desc_type), intent(in)              :: desc_data
+      class(mld_d_base_solver_type), intent(inout) :: sv
+      type(psb_d_vect_type),intent(inout)          :: x
+      type(psb_d_vect_type),intent(inout)          :: y
+      real(psb_dpk_),intent(in)                    :: alpha,beta
+      character(len=1),intent(in)                  :: trans
+      real(psb_dpk_),target, intent(inout)         :: work(:)
+      integer, intent(out)                         :: info
+    end subroutine mld_d_base_solver_apply_vect
+  end interface mld_d_base_solver_apply_vect
+  
+  interface mld_d_base_solver_bld
+    subroutine mld_d_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+       & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      type(psb_dspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(in)                     :: desc_a 
+      class(mld_d_base_solver_type), intent(inout)        :: sv
+      character, intent(in)                               :: upd
+      integer, intent(out)                                :: info
+      type(psb_dspmat_type), intent(in), target, optional :: b
+      class(psb_d_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_d_base_vect_type), intent(in), optional   :: vmold
+    end subroutine mld_d_base_solver_bld
+  end interface mld_d_base_solver_bld
+  
+  interface mld_d_base_solver_check
+    subroutine mld_d_base_solver_check(sv,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+
+      Implicit None
+      
+      ! Arguments
+      class(mld_d_base_solver_type), intent(inout) :: sv
+      integer, intent(out)                   :: info
+    end subroutine mld_d_base_solver_check
+  end interface mld_d_base_solver_check
+  
+  interface mld_d_base_solver_seti
+    subroutine mld_d_base_solver_seti(sv,what,val,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      class(mld_d_base_solver_type), intent(inout) :: sv 
+      integer, intent(in)                          :: what 
+      integer, intent(in)                          :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_d_base_solver_seti
+  end interface mld_d_base_solver_seti
+  
+  interface  mld_d_base_solver_setc
+    subroutine mld_d_base_solver_setc(sv,what,val,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_d_base_solver_type), intent(inout) :: sv
+      integer, intent(in)                          :: what 
+      character(len=*), intent(in)                 :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_d_base_solver_setc
+  end interface mld_d_base_solver_setc
+  
+  interface  mld_d_base_solver_setr
+    subroutine mld_d_base_solver_setr(sv,what,val,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+            
+      Implicit None
+      
+      ! Arguments
+      class(mld_d_base_solver_type), intent(inout) :: sv 
+      integer, intent(in)                          :: what 
+      real(psb_dpk_), intent(in)                   :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_d_base_solver_setr
+  end interface mld_d_base_solver_setr
+  
+  interface  mld_d_base_solver_free
+    subroutine mld_d_base_solver_free(sv,info)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_d_base_solver_type), intent(inout) :: sv
+      integer, intent(out)                         :: info
+    end subroutine mld_d_base_solver_free
+  end interface mld_d_base_solver_free
+  
+  interface  mld_d_base_solver_descr
+    subroutine mld_d_base_solver_descr(sv,info,iout,coarse)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      class(mld_d_base_solver_type), intent(in) :: sv
+      integer, intent(out)                      :: info
+      integer, intent(in), optional             :: iout
+      logical, intent(in), optional             :: coarse
+
+    end subroutine mld_d_base_solver_descr
+  end interface mld_d_base_solver_descr
+  
+  interface  mld_d_base_solver_dmp
+    subroutine mld_d_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
+      import :: psb_desc_type, psb_dspmat_type,  psb_d_base_sparse_mat, &
+           & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, mld_d_base_solver_type
+      
+      implicit none 
+      class(mld_d_base_solver_type), intent(in) :: sv
+      integer, intent(in)              :: ictxt,level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: solver
+    end subroutine mld_d_base_solver_dmp
+  end interface mld_d_base_solver_dmp
+  
+
+
 
 contains
   !
@@ -135,354 +283,6 @@ contains
     val = 0
   end function d_base_solver_get_nzeros
 
-  
-  !
-  ! Apply: comes in two versions, on plain arrays or on encapsulated
-  ! vectors.
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. 
-  ! Question: would it make sense to transform the base version into
-  ! the ID version, i.e. "base_solver" is the identity operator? 
-  ! 
-
-  subroutine d_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)           :: desc_data
-    class(mld_d_base_solver_type), intent(in) :: sv
-    real(psb_dpk_),intent(inout)              :: x(:)
-    real(psb_dpk_),intent(inout)              :: y(:)
-    real(psb_dpk_),intent(in)                 :: alpha,beta
-    character(len=1),intent(in)               :: trans
-    real(psb_dpk_),target, intent(inout)      :: work(:)
-    integer, intent(out)                      :: info
-    
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_apply'
-
-    call psb_erractionsave(err_act)
-    
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine d_base_solver_apply
-
-  subroutine d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)              :: desc_data
-    class(mld_d_base_solver_type), intent(inout) :: sv
-    type(psb_d_vect_type),intent(inout)          :: x
-    type(psb_d_vect_type),intent(inout)          :: y
-    real(psb_dpk_),intent(in)                    :: alpha,beta
-    character(len=1),intent(in)                  :: trans
-    real(psb_dpk_),target, intent(inout)         :: work(:)
-    integer, intent(out)                         :: info
-    
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_apply'
-
-    call psb_erractionsave(err_act)
-    
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine d_base_solver_apply_vect
-
-
-  !
-  ! Build
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. 
-  !
-  subroutine d_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    type(psb_dspmat_type), intent(in), target           :: a
-    Type(psb_desc_type), Intent(in)                     :: desc_a 
-    class(mld_d_base_solver_type), intent(inout)        :: sv
-    character, intent(in)                               :: upd
-    integer, intent(out)                                :: info
-    type(psb_dspmat_type), intent(in), target, optional :: b
-    class(psb_d_base_sparse_mat), intent(in), optional  :: amold
-    class(psb_d_base_vect_type), intent(in), optional   :: vmold
-
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_bld'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_solver_bld
-
-  subroutine d_base_solver_check(sv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_solver_type), intent(inout) :: sv
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_solver_check
-
-  !
-  ! Set.
-  ! The base version does nothing; the principle is that
-  ! SET acts on what is known, and delegates what is unknown.
-  ! Since we are at the bottom of the hierarchy, there's no one
-  ! to delegate, so we do nothing. 
-  !
-  subroutine d_base_solver_seti(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_solver_type), intent(inout) :: sv 
-    integer, intent(in)                          :: what 
-    integer, intent(in)                          :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_seti'
-    
-    ! Correct action here is doing nothing. 
-    info = 0
-    
-    return
-  end subroutine d_base_solver_seti
-
-  subroutine d_base_solver_setc(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_solver_type), intent(inout) :: sv
-    integer, intent(in)                          :: what 
-    character(len=*), intent(in)                 :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act, ival 
-    character(len=20) :: name='d_base_solver_setc'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    call mld_stringval(val,ival,info)
-    if (info == psb_success_) call sv%set(what,ival,info)
-
-    if (info /= psb_success_) goto 9999
-
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_solver_setc
-  
-  subroutine d_base_solver_setr(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_solver_type), intent(inout) :: sv 
-    integer, intent(in)                          :: what 
-    real(psb_dpk_), intent(in)                   :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_setr'
-
-    
-    ! Correct action here is doing nothing. 
-    info = 0
-    
-    return
-  end subroutine d_base_solver_setr
-
-  !
-  ! Free
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. IS THIS CORRECT? I suspect it would be better
-  ! to be silent here, to cover reallocation. 
-  !
-  subroutine d_base_solver_free(sv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_solver_type), intent(inout) :: sv
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_free'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_solver_free
-
-  subroutine d_base_solver_descr(sv,info,iout,coarse)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_d_base_solver_type), intent(in) :: sv
-    integer, intent(out)                      :: info
-    integer, intent(in), optional             :: iout
-    logical, intent(in), optional             :: coarse
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_d_base_solver_descr'
-    integer      :: iout_
-
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_solver_descr
-
-  !
-  ! Dump. For debugging purposes. 
-  !
-  subroutine d_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_d_base_solver_type), intent(in) :: sv
-    integer, intent(in)              :: ictxt,level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: solver_
-    !  len of prefix_ 
-
-    info = 0
-
-    if (present(prefix)) then 
-      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-    else
-      prefix_ = "dump_slv_d"
-    end if
-
-    call psb_info(ictxt,iam,np)
-
-    if (present(solver)) then 
-      solver_ = solver
-    else
-      solver_ = .false. 
-    end if
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    ! At base level do nothing for the solver
-
-  end subroutine d_base_solver_dmp
-
   subroutine d_base_solver_default(sv) 
     implicit none 
     ! Arguments
@@ -492,6 +292,4 @@ contains
     return
   end subroutine d_base_solver_default
 
-
-
 end module mld_d_base_solver_mod

mlprec/mld_d_onelev_impl.f90

@@ -0,0 +1,459 @@
+!!$
+!!$ 
+!!$                           MLD2P4  version 2.0
+!!$  MultiLevel Domain Decomposition Parallel Preconditioners Package
+!!$             based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!!$  
+!!$  (C) Copyright 2008,2009,2010
+!!$
+!!$                      Salvatore Filippone  University of Rome Tor Vergata
+!!$                      Alfredo Buttari      CNRS-IRIT, Toulouse
+!!$                      Pasqua D'Ambra       ICAR-CNR, Naples
+!!$                      Daniela di Serafino  Second University of Naples
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the MLD2P4 group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$
+
+!
+! Subroutine: mld_file_onelev_descr
+! Version: real
+!
+!  This routine prints a description of the preconditioner to the standard 
+!  output or to a file. It must be called after the preconditioner has been
+!  built by mld_precbld.
+!
+! Arguments:
+!  p       -  type(mld_Tprec_type), input.
+!             The preconditioner data structure to be printed out.
+!  info    -  integer, output.
+!             error code.
+!  iout    -  integer, input, optional.
+!             The id of the file where the preconditioner description
+!             will be printed. If iout is not present, then the standard
+!             output is condidered.
+!
+subroutine mld_d_base_onelev_descr(lv,il,nl,info,iout)
+  use psb_base_mod
+  use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_descr
+  Implicit None
+  ! Arguments
+  class(mld_donelev_type), intent(in) :: lv
+  integer, intent(in)                 :: il,nl
+  integer, intent(out)                :: info
+  integer, intent(in), optional       :: iout
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_d_base_onelev_descr'
+  integer      :: iout_
+  logical      :: coarse
+
+
+  call psb_erractionsave(err_act)
+
+
+  coarse = (il==nl)
+
+  if (present(iout)) then 
+    iout_ = iout
+  else 
+    iout_ = 6
+  end if
+
+  write(iout_,*) 
+  if (il == 2) then 
+    call lv%parms%mldescr(iout_,info)
+    write(iout_,*) 
+  end if
+
+  if (coarse)  then 
+    write(iout_,*) ' Level ',il,' (coarsest)'
+  else
+    write(iout_,*) ' Level ',il
+  end if
+
+  call lv%parms%descr(iout_,info,coarse=coarse)
+
+  if (nl > 1) then 
+    if (allocated(lv%map%naggr)) then
+      write(iout_,*) '  Size of coarse matrix: ', &
+           &  sum(lv%map%naggr(:))
+      write(iout_,*) '  Sizes of aggregates: ', &
+           &  lv%map%naggr(:)
+    end if
+  end if
+
+  if (coarse.and.allocated(lv%sm)) &
+       & call lv%sm%descr(info,iout=iout_,coarse=coarse)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_onelev_descr
+
+
+!
+! Subroutines: mld_T_onelev_precfree
+! Version: real
+!
+!  These routines deallocate the mld_Tonelev_type 
+!
+! Arguments:
+!  p       -  type(mld_Tonelev_type), input.
+!             The data structure to be deallocated.
+!  info    -  integer, output.
+!             error code.
+!
+subroutine mld_d_base_onelev_free(lv,info)
+  use psb_base_mod
+  use mld_donelev_mod, mld_protect_name =>:  mld_T_onelev_precfree
+  implicit none 
+
+  class(mld_donelev_type), intent(inout) :: lv
+  integer, intent(out)                :: info
+  integer :: i
+
+  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. 
+  call lv%sm%free(info)
+
+  call lv%ac%free()
+  if (psb_is_ok_desc(lv%desc_ac)) &
+       & call psb_cdfree(lv%desc_ac,info)
+  call lv%map%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) 
+
+  call lv%nullify()
+
+end subroutine mld_d_base_onelev_free
+
+!
+! Onelevel checks. 
+! The number of Jacobi sweeps to be applied is not
+! tied to the Jacobi smoother: logically, you have
+! a smoother and you can choose to apply it any number
+! of times you like. 
+!
+subroutine mld_d_base_onelev_check(lv,info)
+  use psb_base_mod
+  use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_check
+
+  Implicit None
+
+  ! Arguments
+  class(mld_donelev_type), intent(inout) :: lv 
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_onelev_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  call mld_check_def(lv%parms%sweeps,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+  call mld_check_def(lv%parms%sweeps_pre,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+  call mld_check_def(lv%parms%sweeps_post,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+
+
+  if (allocated(lv%sm)) then 
+    call lv%sm%check(info)
+  else 
+    info=3111
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_onelev_check
+
+
+! 
+! Set routines:
+! Parameters belonging here are:
+!   Number of smoothing sweeps;
+!   Smoother position;
+!   Aggregation related parameters
+!   Record request on coarse level solver,
+!    for checks on solver vs. smoother nomenclature
+!    reconciliation. 
+! 
+subroutine mld_d_base_onelev_seti(lv,what,val,info)
+  use psb_base_mod
+  use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_seti
+
+  Implicit None
+
+  ! Arguments
+  class(mld_donelev_type), intent(inout) :: lv 
+  integer, intent(in)                          :: what 
+  integer, intent(in)                          :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_onelev_seti'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  select case (what) 
+
+  case (mld_smoother_sweeps_)
+    lv%parms%sweeps      = val
+    lv%parms%sweeps_pre  = val
+    lv%parms%sweeps_post = val
+
+  case (mld_smoother_sweeps_pre_)
+    lv%parms%sweeps_pre  = val
+
+  case (mld_smoother_sweeps_post_)
+    lv%parms%sweeps_post = val
+
+  case (mld_ml_type_)
+    lv%parms%ml_type       = val
+
+  case (mld_aggr_alg_)
+    lv%parms%aggr_alg      = val
+
+  case (mld_aggr_kind_)
+    lv%parms%aggr_kind     = val
+
+  case (mld_coarse_mat_)
+    lv%parms%coarse_mat    = val
+
+  case (mld_smoother_pos_)
+    lv%parms%smoother_pos  = val
+
+  case (mld_aggr_omega_alg_)
+    lv%parms%aggr_omega_alg= val
+
+  case (mld_aggr_eig_)
+    lv%parms%aggr_eig      = val
+
+  case (mld_aggr_filter_)
+    lv%parms%aggr_filter   = val
+
+  case (mld_coarse_solve_)
+    lv%parms%coarse_solve    = val
+
+  case default
+    if (allocated(lv%sm)) then 
+      call lv%sm%set(what,val,info)
+    end if
+    if (info /= psb_success_) goto 9999
+  end select
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_onelev_seti
+
+subroutine mld_d_base_onelev_setc(lv,what,val,info)
+  use psb_base_mod
+  use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_setc
+
+  Implicit None
+
+  ! Arguments
+  class(mld_donelev_type), intent(inout) :: lv 
+  integer, intent(in)                            :: what 
+  character(len=*), intent(in)                   :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_onelev_setc'
+  integer :: ival 
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  call mld_stringval(val,ival,info)
+  if (info == psb_success_) call lv%set(what,ival,info)
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_onelev_setc
+
+subroutine mld_d_base_onelev_setr(lv,what,val,info)
+  use psb_base_mod
+  use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_setr
+
+  Implicit None
+
+  ! Arguments
+  class(mld_donelev_type), intent(inout) :: lv 
+  integer, intent(in)                            :: what 
+  real(psb_dpk_), intent(in)                     :: val
+  integer, intent(out)                           :: info
+  Integer :: err_act
+  character(len=20)  :: name='d_base_onelev_setr'
+
+  call psb_erractionsave(err_act)
+
+
+  info = psb_success_
+
+  select case (what) 
+
+  case (mld_aggr_omega_val_)
+    lv%parms%aggr_omega_val= val
+
+  case (mld_aggr_thresh_)
+    lv%parms%aggr_thresh   = val
+
+  case default
+    if (allocated(lv%sm)) then 
+      call lv%sm%set(what,val,info)
+    end if
+    if (info /= psb_success_) goto 9999
+  end select
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_d_base_onelev_setr
+
+!
+! Dump on file: can be fine-tuned to include the (aggregated) matrix
+! as well as smoother and solver. 
+!
+subroutine mld_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
+  use psb_base_mod
+  use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_dump
+  implicit none 
+  class(mld_donelev_type), intent(in) :: lv
+  integer, intent(in)              :: level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: ac, rp, smoother, solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: ac_, rp_
+  !  len of prefix_ 
+
+  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 
+    icontxt = lv%base_desc%get_context()
+    call psb_info(icontxt,iam,np)
+  else 
+    icontxt = -1 
+    iam     = -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
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  if (level >= 2) then 
+    if (ac_) then 
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%ac%print(fname,head=head)
+    end if
+    if (rp_) then 
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%map%map_X2Y%print(fname,head=head)
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%map%map_Y2X%print(fname,head=head)
+    end if
+  end if
+  if (allocated(lv%sm)) &
+       & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver)
+
+end subroutine mld_d_base_onelev_dump
+
+

mlprec/mld_d_onelev_mod.f90

@@ -57,7 +57,7 @@ module mld_d_onelev_mod
   use mld_base_prec_type
   use mld_d_base_smoother_mod
   use psb_base_mod, only : psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
-       & psb_dlinmap_type
+       & psb_dlinmap_type, psb_dpk_, psb_long_int_k_, psb_desc_type
   !
   !
   ! Type: mld_Tonelev_type.
@@ -127,31 +127,112 @@ module mld_d_onelev_mod
     type(psb_desc_type), pointer    :: base_desc => null() 
     type(psb_dlinmap_type)          :: map
   contains
-    procedure, pass(lv) :: descr   => d_base_onelev_descr
+    procedure, pass(lv) :: descr   => mld_d_base_onelev_descr
     procedure, pass(lv) :: default => d_base_onelev_default
-    procedure, pass(lv) :: free    => d_base_onelev_free
+    procedure, pass(lv) :: free    => mld_d_base_onelev_free
     procedure, pass(lv) :: nullify => d_base_onelev_nullify
-    procedure, pass(lv) :: check => d_base_onelev_check
+    procedure, pass(lv) :: check => mld_d_base_onelev_check
-    procedure, pass(lv) :: dump  => d_base_onelev_dump
+    procedure, pass(lv) :: dump  => mld_d_base_onelev_dump
-    procedure, pass(lv) :: seti  => d_base_onelev_seti
+    procedure, pass(lv) :: seti  => mld_d_base_onelev_seti
-    procedure, pass(lv) :: setr  => d_base_onelev_setr
+    procedure, pass(lv) :: setr  => mld_d_base_onelev_setr
-    procedure, pass(lv) :: setc  => d_base_onelev_setc
+    procedure, pass(lv) :: setc  => mld_d_base_onelev_setc
     generic, public     :: set   => seti, setr, setc
     procedure, pass(lv) :: sizeof => d_base_onelev_sizeof
     procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros
   end type mld_donelev_type
 
-  private :: d_base_onelev_seti, d_base_onelev_setc, &
+  private :: d_base_onelev_default, d_base_onelev_sizeof, &
-       &  d_base_onelev_setr, d_base_onelev_check, &
+       &  d_base_onelev_nullify, d_base_onelev_get_nzeros
-       &  d_base_onelev_default, d_base_onelev_dump, &
+
-       &  d_base_onelev_descr,  d_base_onelev_sizeof, &
+
-       &  d_base_onelev_free,  d_base_onelev_nullify,&
+
-       &  d_base_onelev_get_nzeros
+  interface mld_d_base_onelev_descr
-
+    subroutine mld_d_base_onelev_descr(lv,il,nl,info,iout)
-
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
-  interface mld_nullify_onelevprec
+           & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type
-    module procedure  mld_nullify_d_onelevprec
+      Implicit None
-  end interface
+      ! Arguments
+      class(mld_donelev_type), intent(in) :: lv
+      integer, intent(in)                 :: il,nl
+      integer, intent(out)                :: info
+      integer, intent(in), optional       :: iout
+    end subroutine mld_d_base_onelev_descr
+  end interface mld_d_base_onelev_descr
+  
+  interface mld_d_base_onelev_free
+    subroutine mld_d_base_onelev_free(lv,info)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type
+      implicit none 
+      
+      class(mld_donelev_type), intent(inout) :: lv
+      integer, intent(out)                :: info
+    end subroutine mld_d_base_onelev_free
+  end interface mld_d_base_onelev_free
+  
+  interface mld_d_base_onelev_check
+    subroutine mld_d_base_onelev_check(lv,info)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      ! Arguments
+      class(mld_donelev_type), intent(inout) :: lv 
+      integer, intent(out)                   :: info
+    end subroutine mld_d_base_onelev_check
+  end interface mld_d_base_onelev_check
+  
+  interface mld_d_base_onelev_seti
+    subroutine mld_d_base_onelev_seti(lv,what,val,info)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_donelev_type), intent(inout) :: lv 
+      integer, intent(in)                          :: what 
+      integer, intent(in)                          :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_d_base_onelev_seti
+  end interface mld_d_base_onelev_seti
+  
+  interface mld_d_base_onelev_setc
+    subroutine mld_d_base_onelev_setc(lv,what,val,info)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      ! Arguments
+      class(mld_donelev_type), intent(inout) :: lv 
+      integer, intent(in)                            :: what 
+      character(len=*), intent(in)                   :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_d_base_onelev_setc
+  end interface mld_d_base_onelev_setc
+  
+  interface mld_d_base_onelev_setr
+    subroutine mld_d_base_onelev_setr(lv,what,val,info)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      
+      class(mld_donelev_type), intent(inout) :: lv 
+      integer, intent(in)                            :: what 
+      real(psb_dpk_), intent(in)                     :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_d_base_onelev_setr
+  end interface mld_d_base_onelev_setr
+
+  interface mld_d_base_onelev_dump
+    subroutine mld_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
+      import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+           & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type
+      implicit none 
+      class(mld_donelev_type), intent(in) :: lv
+      integer, intent(in)              :: level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: ac, rp, smoother, solver
+    end subroutine mld_d_base_onelev_dump
+  end interface mld_d_base_onelev_dump
   
   
 contains
@@ -184,137 +265,6 @@ contains
   end function d_base_onelev_sizeof
 
 
-  !
-  ! Subroutine: mld_file_onelev_descr
-  ! Version: real
-  !
-  !  This routine prints a description of the preconditioner to the standard 
-  !  output or to a file. It must be called after the preconditioner has been
-  !  built by mld_precbld.
-  !
-  ! Arguments:
-  !  p       -  type(mld_Tprec_type), input.
-  !             The preconditioner data structure to be printed out.
-  !  info    -  integer, output.
-  !             error code.
-  !  iout    -  integer, input, optional.
-  !             The id of the file where the preconditioner description
-  !             will be printed. If iout is not present, then the standard
-  !             output is condidered.
-  !
-  subroutine d_base_onelev_descr(lv,il,nl,info,iout)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_donelev_type), intent(in) :: lv
-    integer, intent(in)                 :: il,nl
-    integer, intent(out)                :: info
-    integer, intent(in), optional       :: iout
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_d_base_onelev_descr'
-    integer      :: iout_
-    logical      :: coarse
-
-
-    call psb_erractionsave(err_act)
-
-
-    coarse = (il==nl)
-
-    if (present(iout)) then 
-      iout_ = iout
-    else 
-      iout_ = 6
-    end if
-    
-    write(iout_,*) 
-    if (il == 2) then 
-      call lv%parms%mldescr(iout_,info)
-      write(iout_,*) 
-    end if
-
-    if (coarse)  then 
-      write(iout_,*) ' Level ',il,' (coarsest)'
-    else
-      write(iout_,*) ' Level ',il
-    end if
-
-    call lv%parms%descr(iout_,info,coarse=coarse)
-        
-    if (nl > 1) then 
-      if (allocated(lv%map%naggr)) then
-        write(iout_,*) '  Size of coarse matrix: ', &
-             &  sum(lv%map%naggr(:))
-        write(iout_,*) '  Sizes of aggregates: ', &
-             &  lv%map%naggr(:)
-      end if
-    end if
-
-    if (coarse.and.allocated(lv%sm)) &
-         & call lv%sm%descr(info,iout=iout_,coarse=coarse)
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_onelev_descr
-
-
-  !
-  ! Subroutines: mld_T_onelev_precfree
-  ! Version: real
-  !
-  !  These routines deallocate the mld_Tonelev_type 
-  !
-  ! Arguments:
-  !  p       -  type(mld_Tonelev_type), input.
-  !             The data structure to be deallocated.
-  !  info    -  integer, output.
-  !             error code.
-  !
-  subroutine d_base_onelev_free(lv,info)
-    use psb_base_mod
-    implicit none 
-
-    class(mld_donelev_type), intent(inout) :: lv
-    integer, intent(out)                :: info
-    integer :: i
-
-    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. 
-    call lv%sm%free(info)
-    
-    call lv%ac%free()
-    if (psb_is_ok_desc(lv%desc_ac)) &
-         & call psb_cdfree(lv%desc_ac,info)
-    call lv%map%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) 
-
-    call lv%nullify()
-
-  end subroutine d_base_onelev_free
-
-
   subroutine d_base_onelev_nullify(lv)
     implicit none 
 
@@ -325,69 +275,6 @@ contains
 
   end subroutine d_base_onelev_nullify
 
-
-  subroutine mld_nullify_d_onelevprec(p)
-    implicit none 
-
-    type(mld_donelev_type), intent(inout) :: p
-
-    nullify(p%base_a) 
-    nullify(p%base_desc) 
-
-  end subroutine mld_nullify_d_onelevprec
-
-  !
-  ! Onelevel checks. 
-  ! The number of Jacobi sweeps to be applied is not
-  ! tied to the Jacobi smoother: logically, you have
-  ! a smoother and you can choose to apply it any number
-  ! of times you like. 
-  !
-  subroutine d_base_onelev_check(lv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_donelev_type), intent(inout) :: lv 
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    call mld_check_def(lv%parms%sweeps,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-    call mld_check_def(lv%parms%sweeps_pre,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-    call mld_check_def(lv%parms%sweeps_post,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-
-    
-    if (allocated(lv%sm)) then 
-      call lv%sm%check(info)
-    else 
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_onelev_check
-
   !
   ! Multilevel defaults: 
   !  multiplicative vs. additive ML framework;
@@ -400,8 +287,6 @@ contains
 
   subroutine d_base_onelev_default(lv)
 
-    use psb_base_mod
-
     Implicit None
 
     ! Arguments
@@ -427,241 +312,4 @@ contains
 
   end subroutine d_base_onelev_default
 
-  ! 
-  ! Set routines:
-  ! Parameters belonging here are:
-  !   Number of smoothing sweeps;
-  !   Smoother position;
-  !   Aggregation related parameters
-  !   Record request on coarse level solver,
-  !    for checks on solver vs. smoother nomenclature
-  !    reconciliation. 
-  ! 
-  subroutine d_base_onelev_seti(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_donelev_type), intent(inout) :: lv 
-    integer, intent(in)                          :: what 
-    integer, intent(in)                          :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_seti'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    select case (what) 
-
-    case (mld_smoother_sweeps_)
-      lv%parms%sweeps      = val
-      lv%parms%sweeps_pre  = val
-      lv%parms%sweeps_post = val
-
-    case (mld_smoother_sweeps_pre_)
-      lv%parms%sweeps_pre  = val
-
-    case (mld_smoother_sweeps_post_)
-      lv%parms%sweeps_post = val
-
-    case (mld_ml_type_)
-      lv%parms%ml_type       = val
-
-    case (mld_aggr_alg_)
-      lv%parms%aggr_alg      = val
-
-    case (mld_aggr_kind_)
-      lv%parms%aggr_kind     = val
-
-    case (mld_coarse_mat_)
-      lv%parms%coarse_mat    = val
-
-    case (mld_smoother_pos_)
-      lv%parms%smoother_pos  = val
-
-    case (mld_aggr_omega_alg_)
-      lv%parms%aggr_omega_alg= val
-
-    case (mld_aggr_eig_)
-      lv%parms%aggr_eig      = val
-
-    case (mld_aggr_filter_)
-      lv%parms%aggr_filter   = val
-
-    case (mld_coarse_solve_)
-      lv%parms%coarse_solve    = val
-
-    case default
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info)
-      end if
-      if (info /= psb_success_) goto 9999
-    end select
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_onelev_seti
-
-  subroutine d_base_onelev_setc(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_donelev_type), intent(inout) :: lv 
-    integer, intent(in)                            :: what 
-    character(len=*), intent(in)                   :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_setc'
-    integer :: ival 
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    call mld_stringval(val,ival,info)
-    if (info == psb_success_) call lv%set(what,ival,info)
-
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_onelev_setc
-  
-  subroutine d_base_onelev_setr(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_donelev_type), intent(inout) :: lv 
-    integer, intent(in)                            :: what 
-    real(psb_dpk_), intent(in)                     :: val
-    integer, intent(out)                           :: info
-    Integer :: err_act
-    character(len=20)  :: name='d_base_onelev_setr'
-
-    call psb_erractionsave(err_act)
-
-
-    info = psb_success_
-    
-    select case (what) 
-
-    case (mld_aggr_omega_val_)
-      lv%parms%aggr_omega_val= val
-   
-    case (mld_aggr_thresh_)
-      lv%parms%aggr_thresh   = val
-
-    case default
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info)
-      end if
-      if (info /= psb_success_) goto 9999
-    end select
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine d_base_onelev_setr
-
-  !
-  ! Dump on file: can be fine-tuned to include the (aggregated) matrix
-  ! as well as smoother and solver. 
-  !
-  subroutine d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_donelev_type), intent(in) :: lv
-    integer, intent(in)              :: level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: ac, rp, smoother, solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: ac_, rp_
-    !  len of prefix_ 
-
-    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 
-      icontxt = lv%base_desc%get_context()
-      call psb_info(icontxt,iam,np)
-    else 
-      icontxt = -1 
-      iam     = -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
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    if (level >= 2) then 
-      if (ac_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%ac%print(fname,head=head)
-      end if
-      if (rp_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%map%map_X2Y%print(fname,head=head)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%map%map_Y2X%print(fname,head=head)
-      end if
-    end if
-    if (allocated(lv%sm)) &
-         & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver)
-
-  end subroutine d_base_onelev_dump
-
-
 end module mld_d_onelev_mod

mlprec/mld_s_base_smoother_impl.f90

@@ -0,0 +1,481 @@
+!!$
+!!$ 
+!!$                           MLD2P4  version 2.0
+!!$  MultiLevel Domain Decomposition Parallel Preconditioners Package
+!!$             based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!!$  
+!!$  (C) Copyright 2008,2009,2010
+!!$
+!!$                      Salvatore Filippone  University of Rome Tor Vergata
+!!$                      Alfredo Buttari      CNRS-IRIT, Toulouse
+!!$                      Pasqua D'Ambra       ICAR-CNR, Naples
+!!$                      Daniela di Serafino  Second University of Naples
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the MLD2P4 group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 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.
+!!$ 
+!!$
+
+!
+! Apply: comes in two versions, on plain arrays or on encapsulated
+! vectors.
+! This basic version just applies the local solver, whatever that
+! is. 
+!
+
+subroutine mld_s_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name =>  mld_s_base_smoother_apply
+  implicit none 
+  type(psb_desc_type), intent(in)             :: desc_data
+  class(mld_s_base_smoother_type), intent(in) :: sm
+  real(psb_spk_),intent(inout)                :: x(:)
+  real(psb_spk_),intent(inout)                :: y(:)
+  real(psb_spk_),intent(in)                   :: alpha,beta
+  character(len=1),intent(in)                 :: trans
+  integer, intent(in)                         :: sweeps
+  real(psb_spk_),target, intent(inout)        :: work(:)
+  integer, intent(out)                        :: info
+
+  Integer           :: err_act
+  character(len=20) :: name='s_base_smoother_apply'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
+  else
+    info = 1121
+  endif
+  if (info /= psb_success_) then 
+    call psb_errpush(info,name)
+    goto 9999 
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_s_base_smoother_apply
+
+subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
+     &  trans,sweeps,work,info)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name =>  mld_s_base_smoother_apply_vect
+  implicit none 
+  type(psb_desc_type), intent(in)                :: desc_data
+  class(mld_s_base_smoother_type), intent(inout) :: sm
+  type(psb_s_vect_type),intent(inout)            :: x
+  type(psb_s_vect_type),intent(inout)            :: y
+  real(psb_spk_),intent(in)                      :: alpha,beta
+  character(len=1),intent(in)                    :: trans
+  integer, intent(in)                            :: sweeps
+  real(psb_spk_),target, intent(inout)           :: work(:)
+  integer, intent(out)                           :: info
+
+  Integer           :: err_act
+  character(len=20) :: name='s_base_smoother_apply'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
+  else
+    info = 1121
+  endif
+  if (info /= psb_success_) then 
+    call psb_errpush(info,name)
+    goto 9999 
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_s_base_smoother_apply_vect
+
+!
+! Check:
+! 1. Check that we do have a solver object
+! 2. Call its check method
+!
+
+subroutine mld_s_base_smoother_check(sm,info)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name =>  mld_s_base_smoother_check
+  Implicit None
+
+  ! Arguments
+  class(mld_s_base_smoother_type), intent(inout) :: sm 
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='s_base_smoother_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%check(info)
+  else 
+    info=3111
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_smoother_check
+
+!
+! Set methods: the come in multiple versions according
+! to whether we are setting with integer, real or character
+! input.
+! The basic rule is: if the input refers to a parameter
+! of the smoother, use it, otherwise pass it to the
+! solver object for further processing.
+! Since there are no parameters in the base smoother
+! we just pass everything to the solver object. 
+!
+subroutine mld_s_base_smoother_seti(sm,what,val,info)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name =>  mld_s_base_smoother_seti
+  Implicit None
+  ! Arguments
+  class(mld_s_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  integer, intent(in)                            :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='s_base_smoother_seti'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_smoother_seti
+
+subroutine mld_s_base_smoother_setc(sm,what,val,info)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name =>  mld_s_base_smoother_setc
+  Implicit None
+
+  ! Arguments
+  class(mld_s_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  character(len=*), intent(in)                   :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='s_base_smoother_setc'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_smoother_setc
+
+subroutine mld_s_base_smoother_setr(sm,what,val,info)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name =>  mld_s_base_smoother_setr
+  Implicit None
+
+  ! Arguments
+  class(mld_s_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  real(psb_spk_), intent(in)                     :: val
+  integer, intent(out)                           :: info
+  Integer :: err_act
+  character(len=20)  :: name='s_base_smoother_setr'
+
+  call psb_erractionsave(err_act)
+
+
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_smoother_setr
+
+
+!
+! Build method.
+! At base level we only have to pass data to the inner solver. 
+! AMOLD/VMOLD allow to have any relevant sparse matrix or vector
+! to be stored in a given format. This is essential e.g.
+! when dealing  with GPUs. 
+!
+subroutine mld_s_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name =>  mld_s_base_smoother_bld
+  Implicit None
+
+  ! Arguments
+  type(psb_sspmat_type), intent(in), target      :: a
+  Type(psb_desc_type), Intent(in)                :: desc_a 
+  class(mld_s_base_smoother_type), intent(inout) :: sm 
+  character, intent(in)                          :: upd
+  integer, intent(out)                           :: info
+  class(psb_s_base_sparse_mat), intent(in), optional :: amold
+  class(psb_s_base_vect_type), intent(in), optional  :: vmold
+  Integer           :: err_act
+  character(len=20) :: name='s_base_smoother_bld'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%build(a,desc_a,upd,info,amold=amold,vmold=vmold)
+  else
+    info = 1121
+    call psb_errpush(info,name)
+  endif
+  if (info /= psb_success_) goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_smoother_bld
+
+!
+! Free method (aka destructor).
+! In most cases we could do without; however
+! for cases where there are data objects allocated outside
+! of the Fortran RTE we need to free them explicitly.
+!
+! Even in that case, we could do without this if FINAL
+! subroutines were supported, which is not the case
+
+! in GNU Fortran up to 4.7. 
+!
+subroutine mld_s_base_smoother_free(sm,info)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name => s
+  Implicit None
+
+  ! Arguments
+  class(mld_s_base_smoother_type), intent(inout) :: sm
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='s_base_smoother_free'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%free(info)
+  end if
+  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
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_smoother_free
+
+!
+! Print a description
+!
+
+subroutine mld_s_base_smoother_descr(sm,info,iout,coarse)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name =>  mld_s_base_smoother_descr
+  Implicit None
+
+  ! Arguments
+  class(mld_s_base_smoother_type), intent(in) :: sm
+  integer, intent(out)                        :: info
+  integer, intent(in), optional               :: iout
+  logical, intent(in), optional               :: coarse
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_s_base_smoother_descr'
+  integer :: iout_
+  logical      :: coarse_
+
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (present(coarse)) then 
+    coarse_ = coarse
+  else
+    coarse_ = .false.
+  end if
+  if (present(iout)) then 
+    iout_ = iout
+  else 
+    iout_ = 6
+  end if
+
+  if (.not.coarse_) &
+       &  write(iout_,*) 'Base smoother with local solver'
+  if (allocated(sm%sv)) then 
+    call sm%sv%descr(info,iout,coarse)
+    if (info /= psb_success_) then 
+      info = psb_err_from_subroutine_ 
+      call psb_errpush(info,name,a_err='Local solver')
+      goto 9999
+    end if
+  end if
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_smoother_descr
+
+!
+! Dump 
+! to file, for debugging purposes.
+!
+subroutine mld_s_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+  use psb_base_mod
+  use mld_s_base_smoother_mod, mld_protect_name =>  mld_s_base_smoother_dmp
+  implicit none 
+  class(mld_s_base_smoother_type), intent(in) :: sm
+  integer, intent(in)              :: ictxt,level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: smoother, solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: smoother_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_smth_s"
+  end if
+
+  call psb_info(ictxt,iam,np)
+
+  if (present(smoother)) then 
+    smoother_ = smoother
+  else
+    smoother_ = .false. 
+  end if
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  ! At base level do nothing for the smoother
+  if (allocated(sm%sv)) &
+       & call sm%sv%dump(ictxt,level,info,solver=solver)
+
+end subroutine mld_s_base_smoother_dmp
+

mlprec/mld_s_base_smoother_mod.f90

@@ -54,7 +54,8 @@
 module mld_s_base_smoother_mod
 
   use mld_s_base_solver_mod
-  use psb_base_mod, only : psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type
+  use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_long_int_k_,&
+       & psb_s_vect_type, psb_s_base_vect_type, psb_s_base_sparse_mat, psb_spk_
   
   !
   !
@@ -91,32 +92,155 @@ module mld_s_base_smoother_mod
   type  mld_s_base_smoother_type
     class(mld_s_base_solver_type), allocatable :: sv
   contains
-    procedure, pass(sm) :: check => s_base_smoother_check
+    procedure, pass(sm) :: check => mld_s_base_smoother_check
-    procedure, pass(sm) :: dump  => s_base_smoother_dmp
+    procedure, pass(sm) :: dump  => mld_s_base_smoother_dmp
-    procedure, pass(sm) :: build => s_base_smoother_bld
+    procedure, pass(sm) :: build => mld_s_base_smoother_bld
-    procedure, pass(sm) :: apply_v => s_base_smoother_apply_vect
+    procedure, pass(sm) :: apply_v => mld_s_base_smoother_apply_vect
-    procedure, pass(sm) :: apply_a => s_base_smoother_apply
+    procedure, pass(sm) :: apply_a => mld_s_base_smoother_apply
     generic, public     :: apply => apply_a, apply_v
-    procedure, pass(sm) :: free  => s_base_smoother_free
+    procedure, pass(sm) :: free  => mld_s_base_smoother_free
-    procedure, pass(sm) :: seti  => s_base_smoother_seti
+    procedure, pass(sm) :: seti  => mld_s_base_smoother_seti
-    procedure, pass(sm) :: setc  => s_base_smoother_setc
+    procedure, pass(sm) :: setc  => mld_s_base_smoother_setc
-    procedure, pass(sm) :: setr  => s_base_smoother_setr
+    procedure, pass(sm) :: setr  => mld_s_base_smoother_setr
     generic, public     :: set   => seti, setc, setr
     procedure, pass(sm) :: default => s_base_smoother_default
-    procedure, pass(sm) :: descr =>   s_base_smoother_descr
+    procedure, pass(sm) :: descr =>   mld_s_base_smoother_descr
     procedure, pass(sm) :: sizeof =>  s_base_smoother_sizeof
     procedure, pass(sm) :: get_nzeros => s_base_smoother_get_nzeros
   end type mld_s_base_smoother_type
 
 
-  private :: s_base_smoother_bld,   s_base_smoother_apply, &
+  private :: s_base_smoother_sizeof, &
-       &  s_base_smoother_free,  s_base_smoother_seti, &
+       &  s_base_smoother_default, s_base_smoother_get_nzeros
-       &  s_base_smoother_setc,  s_base_smoother_setr,&
+
-       &  s_base_smoother_descr, s_base_smoother_sizeof, &
+
-       &  s_base_smoother_default, s_base_smoother_check, &
+
-       &  s_base_smoother_dmp, s_base_smoother_apply_vect, &
+  interface mld_s_base_smoother_apply
-       &  s_base_smoother_get_nzeros
+    subroutine mld_s_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
-
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+       & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      type(psb_desc_type), intent(in)             :: desc_data
+      class(mld_s_base_smoother_type), intent(in) :: sm
+      real(psb_spk_),intent(inout)                :: x(:)
+      real(psb_spk_),intent(inout)                :: y(:)
+      real(psb_spk_),intent(in)                   :: alpha,beta
+      character(len=1),intent(in)                 :: trans
+      integer, intent(in)                         :: sweeps
+      real(psb_spk_),target, intent(inout)        :: work(:)
+      integer, intent(out)                        :: info
+    end subroutine mld_s_base_smoother_apply
+  end interface mld_s_base_smoother_apply
+  
+  interface mld_s_base_smoother_apply_vect
+    subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
+         &  trans,sweeps,work,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      type(psb_desc_type), intent(in)                :: desc_data
+      class(mld_s_base_smoother_type), intent(inout) :: sm
+      type(psb_s_vect_type),intent(inout)            :: x
+      type(psb_s_vect_type),intent(inout)            :: y
+      real(psb_spk_),intent(in)                      :: alpha,beta
+      character(len=1),intent(in)                    :: trans
+      integer, intent(in)                            :: sweeps
+      real(psb_spk_),target, intent(inout)           :: work(:)
+      integer, intent(out)                           :: info
+    end subroutine mld_s_base_smoother_apply_vect
+  end interface mld_s_base_smoother_apply_vect
+  
+  interface mld_s_base_smoother_check
+    subroutine mld_s_base_smoother_check(sm,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      ! Arguments
+      class(mld_s_base_smoother_type), intent(inout) :: sm 
+      integer, intent(out)                   :: info
+    end subroutine mld_s_base_smoother_check
+  end interface mld_s_base_smoother_check
+  
+  interface mld_s_base_smoother_seti
+    subroutine mld_s_base_smoother_seti(sm,what,val,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      ! Arguments
+      class(mld_s_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      integer, intent(in)                            :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_s_base_smoother_seti
+  end interface mld_s_base_smoother_seti
+  
+  interface mld_s_base_smoother_setc
+    subroutine mld_s_base_smoother_setc(sm,what,val,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      class(mld_s_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      character(len=*), intent(in)                   :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_s_base_smoother_setc
+  end interface mld_s_base_smoother_setc
+  
+  interface mld_s_base_smoother_setr
+    subroutine mld_s_base_smoother_setr(sm,what,val,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      ! Arguments
+      class(mld_s_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      real(psb_spk_), intent(in)                     :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_s_base_smoother_setr
+  end interface mld_s_base_smoother_setr
+  
+  interface mld_s_base_smoother_bld
+    subroutine mld_s_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      ! Arguments
+      type(psb_sspmat_type), intent(in), target      :: a
+      Type(psb_desc_type), Intent(in)                :: desc_a 
+      class(mld_s_base_smoother_type), intent(inout) :: sm 
+      character, intent(in)                          :: upd
+      integer, intent(out)                           :: info
+      class(psb_s_base_sparse_mat), intent(in), optional :: amold
+      class(psb_s_base_vect_type), intent(in), optional  :: vmold
+    end subroutine mld_s_base_smoother_bld
+  end interface mld_s_base_smoother_bld
+  
+  interface mld_s_base_smoother_free
+    subroutine mld_s_base_smoother_free(sm,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      ! Arguments
+      class(mld_s_base_smoother_type), intent(inout) :: sm
+      integer, intent(out)                           :: info
+    end subroutine mld_s_base_smoother_free
+  end interface mld_s_base_smoother_free
+  
+  interface mld_s_base_smoother_descr
+    subroutine mld_s_base_smoother_descr(sm,info,iout,coarse)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      ! Arguments
+      class(mld_s_base_smoother_type), intent(in) :: sm
+      integer, intent(out)                        :: info
+      integer, intent(in), optional               :: iout
+      logical, intent(in), optional               :: coarse
+    end subroutine mld_s_base_smoother_descr
+  end interface mld_s_base_smoother_descr
+  
+  interface mld_s_base_smoother_dmp
+    subroutine mld_s_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_smoother_type
+      class(mld_s_base_smoother_type), intent(in) :: sm
+      integer, intent(in)              :: ictxt,level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: smoother, solver
+    end subroutine mld_s_base_smoother_dmp
+  end interface mld_s_base_smoother_dmp
   
 contains
   !
@@ -149,451 +273,6 @@ contains
     return
   end function s_base_smoother_sizeof
 
-
-  !
-  ! Apply: comes in two versions, on plain arrays or on encapsulated
-  ! vectors.
-  ! This basic version just applies the local solver, whatever that
-  ! is. 
-  !
-
-  subroutine s_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)             :: desc_data
-    class(mld_s_base_smoother_type), intent(in) :: sm
-    real(psb_spk_),intent(inout)                :: x(:)
-    real(psb_spk_),intent(inout)                :: y(:)
-    real(psb_spk_),intent(in)                   :: alpha,beta
-    character(len=1),intent(in)                 :: trans
-    integer, intent(in)                         :: sweeps
-    real(psb_spk_),target, intent(inout)        :: work(:)
-    integer, intent(out)                        :: info
-    
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_apply'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
-    else
-      info = 1121
-    endif
-    if (info /= psb_success_) then 
-      call psb_errpush(info,name)
-      goto 9999 
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine s_base_smoother_apply
-
-  subroutine s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
-       &  trans,sweeps,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)                :: desc_data
-    class(mld_s_base_smoother_type), intent(inout) :: sm
-    type(psb_s_vect_type),intent(inout)            :: x
-    type(psb_s_vect_type),intent(inout)            :: y
-    real(psb_spk_),intent(in)                      :: alpha,beta
-    character(len=1),intent(in)                    :: trans
-    integer, intent(in)                            :: sweeps
-    real(psb_spk_),target, intent(inout)           :: work(:)
-    integer, intent(out)                           :: info
-    
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_apply'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
-    else
-      info = 1121
-    endif
-    if (info /= psb_success_) then 
-      call psb_errpush(info,name)
-      goto 9999 
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine s_base_smoother_apply_vect
-
-  !
-  ! Check:
-  ! 1. Check that we do have a solver object
-  ! 2. Call its check method
-  !
-
-  subroutine s_base_smoother_check(sm,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_smoother_type), intent(inout) :: sm 
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%check(info)
-    else 
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_smoother_check
-
-  !
-  ! Set methods: the come in multiple versions according
-  ! to whether we are setting with integer, real or character
-  ! input.
-  ! The basic rule is: if the input refers to a parameter
-  ! of the smoother, use it, otherwise pass it to the
-  ! solver object for further processing.
-  ! Since there are no parameters in the base smoother
-  ! we just pass everything to the solver object. 
-  !
-  subroutine s_base_smoother_seti(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    integer, intent(in)                            :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_seti'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_smoother_seti
-
-  subroutine s_base_smoother_setc(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    character(len=*), intent(in)                   :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_setc'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_smoother_setc
-  
-  subroutine s_base_smoother_setr(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    real(psb_spk_), intent(in)                     :: val
-    integer, intent(out)                           :: info
-    Integer :: err_act
-    character(len=20)  :: name='d_base_smoother_setr'
-
-    call psb_erractionsave(err_act)
-
-
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_smoother_setr
-
-
-  !
-  ! Build method.
-  ! At base level we only have to pass data to the inner solver. 
-  ! AMOLD/VMOLD allow to have any relevant sparse matrix or vector
-  ! to be stored in a given format. This is essential e.g.
-  ! when dealing  with GPUs. 
-  !
-  subroutine s_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    type(psb_sspmat_type), intent(in), target      :: a
-    Type(psb_desc_type), Intent(in)                :: desc_a 
-    class(mld_s_base_smoother_type), intent(inout) :: sm 
-    character, intent(in)                          :: upd
-    integer, intent(out)                           :: info
-    class(psb_s_base_sparse_mat), intent(in), optional :: amold
-    class(psb_s_base_vect_type), intent(in), optional  :: vmold
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_bld'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%build(a,desc_a,upd,info,amold=amold,vmold=vmold)
-    else
-      info = 1121
-      call psb_errpush(info,name)
-    endif
-    if (info /= psb_success_) goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_smoother_bld
-
-  !
-  ! Free method (aka destructor).
-  ! In most cases we could do without; however
-  ! for cases where there are data objects allocated outside
-  ! of the Fortran RTE we need to free them explicitly.
-  !
-  ! Even in that case, we could do without this if FINAL
-  ! subroutines were supported, which is not the case
-  ! in GNU Fortran up to 4.7. 
-  !
-  subroutine s_base_smoother_free(sm,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_smoother_type), intent(inout) :: sm
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_free'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    
-    if (allocated(sm%sv)) then 
-      call sm%sv%free(info)
-    end if
-    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
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_smoother_free
-
-  !
-  ! Print a description
-  !
-
-  subroutine s_base_smoother_descr(sm,info,iout,coarse)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_smoother_type), intent(in) :: sm
-    integer, intent(out)                        :: info
-    integer, intent(in), optional               :: iout
-    logical, intent(in), optional               :: coarse
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_s_base_smoother_descr'
-    integer :: iout_
-    logical      :: coarse_
-
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (present(coarse)) then 
-      coarse_ = coarse
-    else
-      coarse_ = .false.
-    end if
-    if (present(iout)) then 
-      iout_ = iout
-    else 
-      iout_ = 6
-    end if
-
-    if (.not.coarse_) &
-         &  write(iout_,*) 'Base smoother with local solver'
-    if (allocated(sm%sv)) then 
-      call sm%sv%descr(info,iout,coarse)
-      if (info /= psb_success_) then 
-        info = psb_err_from_subroutine_ 
-        call psb_errpush(info,name,a_err='Local solver')
-        goto 9999
-      end if
-    end if
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_smoother_descr
-
-  !
-  ! Dump 
-  ! to file, for debugging purposes.
-  !
-  subroutine s_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_s_base_smoother_type), intent(in) :: sm
-    integer, intent(in)              :: ictxt,level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: smoother, solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: smoother_
-    !  len of prefix_ 
-
-    info = 0
-
-    if (present(prefix)) then 
-      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-    else
-      prefix_ = "dump_smth_d"
-    end if
-
-    call psb_info(ictxt,iam,np)
-
-    if (present(smoother)) then 
-      smoother_ = smoother
-    else
-      smoother_ = .false. 
-    end if
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    ! At base level do nothing for the smoother
-    if (allocated(sm%sv)) &
-         & call sm%sv%dump(ictxt,level,info,solver=solver)
-
-  end subroutine s_base_smoother_dmp
-
   !
   ! Set sensible defaults.
   ! To be called immediately after allocation
@@ -610,5 +289,4 @@ contains
   end subroutine s_base_smoother_default
 
 
-
 end module mld_s_base_smoother_mod

mlprec/mld_s_base_solver_impl.f90

@@ -0,0 +1,338 @@
+!
+! Apply: comes in two versions, on plain arrays or on encapsulated
+! vectors.
+! The base version throws an error, since it means that no explicit
+! choice was made. 
+! Question: would it make sense to transform the base version into
+! the ID version, i.e. "base_solver" is the identity operator? 
+! 
+
+subroutine mld_s_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_apply
+  implicit none 
+  type(psb_desc_type), intent(in)           :: desc_data
+  class(mld_s_base_solver_type), intent(in) :: sv
+  real(psb_spk_),intent(inout)              :: x(:)
+  real(psb_spk_),intent(inout)              :: y(:)
+  real(psb_spk_),intent(in)                 :: alpha,beta
+  character(len=1),intent(in)               :: trans
+  real(psb_spk_),target, intent(inout)      :: work(:)
+  integer, intent(out)                      :: info
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_s_base_solver_apply
+
+subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_apply_vect
+  implicit none 
+  type(psb_desc_type), intent(in)              :: desc_data
+  class(mld_s_base_solver_type), intent(inout) :: sv
+  type(psb_s_vect_type),intent(inout)          :: x
+  type(psb_s_vect_type),intent(inout)          :: y
+  real(psb_spk_),intent(in)                    :: alpha,beta
+  character(len=1),intent(in)                  :: trans
+  real(psb_spk_),target, intent(inout)         :: work(:)
+  integer, intent(out)                         :: info
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_s_base_solver_apply_vect
+
+
+!
+! Build
+! The base version throws an error, since it means that no explicit
+! choice was made. 
+!
+subroutine mld_s_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_bld
+  Implicit None
+  ! Arguments
+  type(psb_sspmat_type), intent(in), target           :: a
+  Type(psb_desc_type), Intent(in)                     :: desc_a 
+  class(mld_s_base_solver_type), intent(inout)        :: sv
+  character, intent(in)                               :: upd
+  integer, intent(out)                                :: info
+  type(psb_sspmat_type), intent(in), target, optional :: b
+  class(psb_s_base_sparse_mat), intent(in), optional  :: amold
+  class(psb_s_base_vect_type), intent(in), optional   :: vmold
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_bld'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_solver_bld
+
+subroutine mld_s_base_solver_check(sv,info)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_check
+  Implicit None
+  ! Arguments
+  class(mld_s_base_solver_type), intent(inout) :: sv
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_solver_check
+
+!
+! Set.
+! The base version does nothing; the principle is that
+! SET acts on what is known, and delegates what is unknown.
+! Since we are at the bottom of the hierarchy, there's no one
+! to delegate, so we do nothing. 
+!
+subroutine mld_s_base_solver_seti(sv,what,val,info)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_seti
+  Implicit None
+  ! Arguments
+  class(mld_s_base_solver_type), intent(inout) :: sv 
+  integer, intent(in)                          :: what 
+  integer, intent(in)                          :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_seti'
+
+  ! Correct action here is doing nothing. 
+  info = 0
+
+  return
+end subroutine mld_s_base_solver_seti
+
+subroutine mld_s_base_solver_setc(sv,what,val,info)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_setc
+  Implicit None
+  ! Arguments
+  class(mld_s_base_solver_type), intent(inout) :: sv
+  integer, intent(in)                          :: what 
+  character(len=*), intent(in)                 :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act, ival 
+  character(len=20) :: name='d_base_solver_setc'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  call mld_stringval(val,ival,info)
+  if (info == psb_success_) call sv%set(what,ival,info)
+
+  if (info /= psb_success_) goto 9999
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_solver_setc
+
+subroutine mld_s_base_solver_setr(sv,what,val,info)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_setr
+  Implicit None
+  ! Arguments
+  class(mld_s_base_solver_type), intent(inout) :: sv 
+  integer, intent(in)                          :: what 
+  real(psb_spk_), intent(in)                   :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_setr'
+
+
+  ! Correct action here is doing nothing. 
+  info = 0
+
+  return
+end subroutine mld_s_base_solver_setr
+
+!
+! Free
+! The base version throws an error, since it means that no explicit
+! choice was made. IS THIS CORRECT? I suspect it would be better
+! to be silent here, to cover reallocation. 
+!
+subroutine mld_s_base_solver_free(sv,info)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_free
+  Implicit None
+  ! Arguments
+  class(mld_s_base_solver_type), intent(inout) :: sv
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_free'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_solver_free
+
+subroutine mld_s_base_solver_descr(sv,info,iout,coarse)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_descr
+  Implicit None
+  ! Arguments
+  class(mld_s_base_solver_type), intent(in) :: sv
+  integer, intent(out)                      :: info
+  integer, intent(in), optional             :: iout
+  logical, intent(in), optional             :: coarse
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_s_base_solver_descr'
+  integer      :: iout_
+
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_solver_descr
+
+!
+! Dump. For debugging purposes. 
+!
+subroutine mld_s_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
+  use psb_base_mod
+  use mld_s_base_solver_mod, mld_protect_name =>  mld_s_base_solver_dmp
+  implicit none 
+  class(mld_s_base_solver_type), intent(in) :: sv
+  integer, intent(in)              :: ictxt,level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: solver_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_slv_s"
+  end if
+
+  call psb_info(ictxt,iam,np)
+
+  if (present(solver)) then 
+    solver_ = solver
+  else
+    solver_ = .false. 
+  end if
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  ! At base level do nothing for the solver
+
+end subroutine mld_s_base_solver_dmp
+

mlprec/mld_s_base_solver_mod.f90

@@ -54,7 +54,8 @@
 module mld_s_base_solver_mod
 
   use mld_base_prec_type
-  use psb_base_mod, only : psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type
+  use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_long_int_k_, &
+       & psb_s_vect_type, psb_s_base_vect_type, psb_s_base_sparse_mat, psb_spk_
   !
   ! 
   ! Type: mld_T_base_solver_type.
@@ -83,32 +84,179 @@ module mld_s_base_solver_mod
 
   type mld_s_base_solver_type
   contains
-    procedure, pass(sv) :: check => s_base_solver_check
+    procedure, pass(sv) :: check => mld_s_base_solver_check
-    procedure, pass(sv) :: dump  => s_base_solver_dmp
+    procedure, pass(sv) :: dump  => mld_s_base_solver_dmp
-    procedure, pass(sv) :: build => s_base_solver_bld
+    procedure, pass(sv) :: build => mld_s_base_solver_bld
-    procedure, pass(sv) :: apply_v => s_base_solver_apply_vect
+    procedure, pass(sv) :: apply_v => mld_s_base_solver_apply_vect
-    procedure, pass(sv) :: apply_a => s_base_solver_apply
+    procedure, pass(sv) :: apply_a => mld_s_base_solver_apply
     generic, public     :: apply => apply_a, apply_v
-    procedure, pass(sv) :: free  => s_base_solver_free
+    procedure, pass(sv) :: free  => mld_s_base_solver_free
-    procedure, pass(sv) :: seti  => s_base_solver_seti
+    procedure, pass(sv) :: seti  => mld_s_base_solver_seti
-    procedure, pass(sv) :: setc  => s_base_solver_setc
+    procedure, pass(sv) :: setc  => mld_s_base_solver_setc
-    procedure, pass(sv) :: setr  => s_base_solver_setr
+    procedure, pass(sv) :: setr  => mld_s_base_solver_setr
     generic, public     :: set   => seti, setc, setr
     procedure, pass(sv) :: default => s_base_solver_default
-    procedure, pass(sv) :: descr   => s_base_solver_descr
+    procedure, pass(sv) :: descr   => mld_s_base_solver_descr
     procedure, pass(sv) :: sizeof  => s_base_solver_sizeof
     procedure, pass(sv) :: get_nzeros => s_base_solver_get_nzeros
   end type mld_s_base_solver_type
 
-  private :: s_base_solver_bld,  s_base_solver_apply, &
+  private :: s_base_solver_sizeof, s_base_solver_default,&
-       &  s_base_solver_free,    s_base_solver_seti, &
-       &  s_base_solver_setc,    s_base_solver_setr, &
-       &  s_base_solver_descr,   s_base_solver_sizeof, &
-       &  s_base_solver_default, s_base_solver_check,&
-       &  s_base_solver_dmp, s_base_solver_apply_vect, &
        &  s_base_solver_get_nzeros
 
 
+  interface  mld_s_base_solver_apply
+    subroutine mld_s_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+       & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+      type(psb_desc_type), intent(in)           :: desc_data
+      class(mld_s_base_solver_type), intent(in) :: sv
+      real(psb_spk_),intent(inout)              :: x(:)
+      real(psb_spk_),intent(inout)              :: y(:)
+      real(psb_spk_),intent(in)                 :: alpha,beta
+      character(len=1),intent(in)               :: trans
+      real(psb_spk_),target, intent(inout)      :: work(:)
+      integer, intent(out)                      :: info
+    end subroutine mld_s_base_solver_apply
+  end interface mld_s_base_solver_apply
+  
+      
+  interface mld_s_base_solver_apply_vect
+    subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+      
+      type(psb_desc_type), intent(in)              :: desc_data
+      class(mld_s_base_solver_type), intent(inout) :: sv
+      type(psb_s_vect_type),intent(inout)          :: x
+      type(psb_s_vect_type),intent(inout)          :: y
+      real(psb_spk_),intent(in)                    :: alpha,beta
+      character(len=1),intent(in)                  :: trans
+      real(psb_spk_),target, intent(inout)         :: work(:)
+      integer, intent(out)                         :: info
+    end subroutine mld_s_base_solver_apply_vect
+  end interface mld_s_base_solver_apply_vect
+  
+  interface mld_s_base_solver_bld
+    subroutine mld_s_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+       & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      type(psb_sspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(in)                     :: desc_a 
+      class(mld_s_base_solver_type), intent(inout)        :: sv
+      character, intent(in)                               :: upd
+      integer, intent(out)                                :: info
+      type(psb_sspmat_type), intent(in), target, optional :: b
+      class(psb_s_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_s_base_vect_type), intent(in), optional   :: vmold
+    end subroutine mld_s_base_solver_bld
+  end interface mld_s_base_solver_bld
+  
+  interface mld_s_base_solver_check
+    subroutine mld_s_base_solver_check(sv,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+
+      Implicit None
+      
+      ! Arguments
+      class(mld_s_base_solver_type), intent(inout) :: sv
+      integer, intent(out)                   :: info
+    end subroutine mld_s_base_solver_check
+  end interface mld_s_base_solver_check
+  
+  interface mld_s_base_solver_seti
+    subroutine mld_s_base_solver_seti(sv,what,val,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      class(mld_s_base_solver_type), intent(inout) :: sv 
+      integer, intent(in)                          :: what 
+      integer, intent(in)                          :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_s_base_solver_seti
+  end interface mld_s_base_solver_seti
+  
+  interface  mld_s_base_solver_setc
+    subroutine mld_s_base_solver_setc(sv,what,val,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_s_base_solver_type), intent(inout) :: sv
+      integer, intent(in)                          :: what 
+      character(len=*), intent(in)                 :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_s_base_solver_setc
+  end interface mld_s_base_solver_setc
+  
+  interface  mld_s_base_solver_setr
+    subroutine mld_s_base_solver_setr(sv,what,val,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+            
+      Implicit None
+      
+      ! Arguments
+      class(mld_s_base_solver_type), intent(inout) :: sv 
+      integer, intent(in)                          :: what 
+      real(psb_spk_), intent(in)                   :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_s_base_solver_setr
+  end interface mld_s_base_solver_setr
+  
+  interface  mld_s_base_solver_free
+    subroutine mld_s_base_solver_free(sv,info)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_s_base_solver_type), intent(inout) :: sv
+      integer, intent(out)                         :: info
+    end subroutine mld_s_base_solver_free
+  end interface mld_s_base_solver_free
+  
+  interface  mld_s_base_solver_descr
+    subroutine mld_s_base_solver_descr(sv,info,iout,coarse)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      class(mld_s_base_solver_type), intent(in) :: sv
+      integer, intent(out)                      :: info
+      integer, intent(in), optional             :: iout
+      logical, intent(in), optional             :: coarse
+
+    end subroutine mld_s_base_solver_descr
+  end interface mld_s_base_solver_descr
+  
+  interface  mld_s_base_solver_dmp
+    subroutine mld_s_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
+      import :: psb_desc_type, psb_sspmat_type,  psb_s_base_sparse_mat, &
+           & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, mld_s_base_solver_type
+      
+      implicit none 
+      class(mld_s_base_solver_type), intent(in) :: sv
+      integer, intent(in)              :: ictxt,level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: solver
+    end subroutine mld_s_base_solver_dmp
+  end interface mld_s_base_solver_dmp
+  
+
+
 
 contains
   !
@@ -135,354 +283,6 @@ contains
     val = 0
   end function s_base_solver_get_nzeros
 
-  
-  !
-  ! Apply: comes in two versions, on plain arrays or on encapsulated
-  ! vectors.
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. 
-  ! Question: would it make sense to transform the base version into
-  ! the ID version, i.e. "base_solver" is the identity operator? 
-  ! 
-
-  subroutine s_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)           :: desc_data
-    class(mld_s_base_solver_type), intent(in) :: sv
-    real(psb_spk_),intent(inout)              :: x(:)
-    real(psb_spk_),intent(inout)              :: y(:)
-    real(psb_spk_),intent(in)                 :: alpha,beta
-    character(len=1),intent(in)               :: trans
-    real(psb_spk_),target, intent(inout)      :: work(:)
-    integer, intent(out)                      :: info
-    
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_apply'
-
-    call psb_erractionsave(err_act)
-    
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine s_base_solver_apply
-
-  subroutine s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)              :: desc_data
-    class(mld_s_base_solver_type), intent(inout) :: sv
-    type(psb_s_vect_type),intent(inout)          :: x
-    type(psb_s_vect_type),intent(inout)          :: y
-    real(psb_spk_),intent(in)                    :: alpha,beta
-    character(len=1),intent(in)                  :: trans
-    real(psb_spk_),target, intent(inout)         :: work(:)
-    integer, intent(out)                         :: info
-    
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_apply'
-
-    call psb_erractionsave(err_act)
-    
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine s_base_solver_apply_vect
-
-
-  !
-  ! Build
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. 
-  !
-  subroutine s_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    type(psb_sspmat_type), intent(in), target           :: a
-    Type(psb_desc_type), Intent(in)                     :: desc_a 
-    class(mld_s_base_solver_type), intent(inout)        :: sv
-    character, intent(in)                               :: upd
-    integer, intent(out)                                :: info
-    type(psb_sspmat_type), intent(in), target, optional :: b
-    class(psb_s_base_sparse_mat), intent(in), optional  :: amold
-    class(psb_s_base_vect_type), intent(in), optional   :: vmold
-
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_bld'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_solver_bld
-
-  subroutine s_base_solver_check(sv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_solver_type), intent(inout) :: sv
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_solver_check
-
-  !
-  ! Set.
-  ! The base version does nothing; the principle is that
-  ! SET acts on what is known, and delegates what is unknown.
-  ! Since we are at the bottom of the hierarchy, there's no one
-  ! to delegate, so we do nothing. 
-  !
-  subroutine s_base_solver_seti(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_solver_type), intent(inout) :: sv 
-    integer, intent(in)                          :: what 
-    integer, intent(in)                          :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_seti'
-    
-    ! Correct action here is doing nothing. 
-    info = 0
-    
-    return
-  end subroutine s_base_solver_seti
-
-  subroutine s_base_solver_setc(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_solver_type), intent(inout) :: sv
-    integer, intent(in)                          :: what 
-    character(len=*), intent(in)                 :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act, ival 
-    character(len=20) :: name='d_base_solver_setc'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    call mld_stringval(val,ival,info)
-    if (info == psb_success_) call sv%set(what,ival,info)
-
-    if (info /= psb_success_) goto 9999
-
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_solver_setc
-  
-  subroutine s_base_solver_setr(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_solver_type), intent(inout) :: sv 
-    integer, intent(in)                          :: what 
-    real(psb_spk_), intent(in)                   :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_setr'
-
-    
-    ! Correct action here is doing nothing. 
-    info = 0
-    
-    return
-  end subroutine s_base_solver_setr
-
-  !
-  ! Free
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. IS THIS CORRECT? I suspect it would be better
-  ! to be silent here, to cover reallocation. 
-  !
-  subroutine s_base_solver_free(sv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_solver_type), intent(inout) :: sv
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_free'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_solver_free
-
-  subroutine s_base_solver_descr(sv,info,iout,coarse)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_s_base_solver_type), intent(in) :: sv
-    integer, intent(out)                      :: info
-    integer, intent(in), optional             :: iout
-    logical, intent(in), optional             :: coarse
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_s_base_solver_descr'
-    integer      :: iout_
-
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_solver_descr
-
-  !
-  ! Dump. For debugging purposes. 
-  !
-  subroutine s_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_s_base_solver_type), intent(in) :: sv
-    integer, intent(in)              :: ictxt,level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: solver_
-    !  len of prefix_ 
-
-    info = 0
-
-    if (present(prefix)) then 
-      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-    else
-      prefix_ = "dump_slv_d"
-    end if
-
-    call psb_info(ictxt,iam,np)
-
-    if (present(solver)) then 
-      solver_ = solver
-    else
-      solver_ = .false. 
-    end if
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    ! At base level do nothing for the solver
-
-  end subroutine s_base_solver_dmp
-
   subroutine s_base_solver_default(sv) 
     implicit none 
     ! Arguments
@@ -492,6 +292,4 @@ contains
     return
   end subroutine s_base_solver_default
 
-
-
 end module mld_s_base_solver_mod

mlprec/mld_s_ilu_impl.f90

@@ -0,0 +1,472 @@
+!!$
+!!$ 
+!!$                           MLD2P4  version 2.0
+!!$  MultiLevel Domain Decomposition Parallel Preconditioners Package
+!!$             based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!!$  
+!!$  (C) Copyright 2008,2009,2010, 2010
+!!$
+!!$                      Salvatore Filippone  University of Rome Tor Vergata
+!!$                      Alfredo Buttari      CNRS-IRIT, Toulouse
+!!$                      Pasqua D'Ambra       ICAR-CNR, Naples
+!!$                      Daniela di Serafino  Second University of Naples
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the MLD2P4 group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$
+!
+!
+!
+!
+!
+!
+
+
+subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_s_ilu_solver, mld_protect_name => mld_s_ilu_solver_apply_vect
+  implicit none 
+  type(psb_desc_type), intent(in)             :: desc_data
+  class(mld_s_ilu_solver_type), intent(inout) :: sv
+  type(psb_s_vect_type),intent(inout)         :: x
+  type(psb_s_vect_type),intent(inout)         :: y
+  real(psb_spk_),intent(in)                   :: alpha,beta
+  character(len=1),intent(in)                 :: trans
+  real(psb_spk_),target, intent(inout)        :: work(:)
+  integer, intent(out)                        :: info
+
+  integer    :: n_row,n_col
+  type(psb_s_vect_type) :: wv
+  real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
+  integer    :: ictxt,np,me,i, err_act
+  character          :: trans_
+  character(len=20)  :: name='s_ilu_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  trans_ = psb_toupper(trans)
+  select case(trans_)
+  case('N')
+  case('T')
+  case('C')
+  case default
+    call psb_errpush(psb_err_iarg_invalid_i_,name)
+    goto 9999
+  end select
+
+  n_row = desc_data%get_local_rows()
+  n_col = desc_data%get_local_cols()
+
+
+  if (x%get_nrows() < n_row) then 
+    info = 36
+    call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/))
+    goto 9999
+  end if
+  if (y%get_nrows() < n_row) then 
+    info = 36
+    call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/))
+    goto 9999
+  end if
+  if (sv%dv%get_nrows() < n_row) then
+    info = 1124
+    call psb_errpush(info,name,a_err="preconditioner: DV")
+    goto 9999
+  end if
+
+
+
+  if (n_col <= size(work)) then 
+    ww => work(1:n_col)
+    if ((4*n_col+n_col) <= size(work)) then 
+      aux => work(n_col+1:)
+    else
+      allocate(aux(4*n_col),stat=info)
+    endif
+  else
+    allocate(ww(n_col),aux(4*n_col),stat=info)
+  endif
+
+  call wv%bld(n_col,mold=x%v)
+
+  if (info /= psb_success_) then 
+    info=psb_err_alloc_request_
+    call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
+         & a_err='real(psb_spk_)')
+    goto 9999      
+  end if
+
+
+
+  select case(trans_)
+  case('N')
+    call psb_spsm(sone,sv%l,x,szero,wv,desc_data,info,&
+         & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
+
+    if (info == psb_success_) call psb_spsm(alpha,sv%u,wv,beta,y,desc_data,info,&
+         & trans=trans_,scale='U',choice=psb_none_, work=aux)
+
+  case('T')
+    call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
+         & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
+    if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
+         & trans=trans_,scale='U',choice=psb_none_,work=aux)
+
+  case('C')
+    ! For real this is the same of T but in the future we will move to
+    ! a preprocessed version, so we need a placeholder
+    call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
+         & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
+    if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
+         & trans=trans_,scale='U',choice=psb_none_,work=aux)
+
+  case default
+    call psb_errpush(psb_err_internal_error_,name,a_err='Invalid TRANS in ILU subsolve')
+    goto 9999
+  end select
+
+
+  if (info /= psb_success_) then
+
+    call psb_errpush(psb_err_internal_error_,name,a_err='Error in subsolve')
+    goto 9999
+  endif
+  call wv%free(info)
+  if (n_col <= size(work)) then 
+    if ((4*n_col+n_col) <= size(work)) then 
+    else
+      deallocate(aux)
+    endif
+  else
+    deallocate(ww,aux)
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_s_ilu_solver_apply_vect
+
+
+subroutine mld_s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_s_ilu_solver, mld_protect_name => mld_s_ilu_solver_apply
+  implicit none 
+  type(psb_desc_type), intent(in)      :: desc_data
+  class(mld_s_ilu_solver_type), intent(in) :: sv
+  real(psb_spk_),intent(inout)         :: x(:)
+  real(psb_spk_),intent(inout)         :: y(:)
+  real(psb_spk_),intent(in)            :: alpha,beta
+  character(len=1),intent(in)          :: trans
+  real(psb_spk_),target, intent(inout) :: work(:)
+  integer, intent(out)                 :: info
+
+  integer    :: n_row,n_col
+  real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
+  integer    :: ictxt,np,me,i, err_act
+  character          :: trans_
+  character(len=20)  :: name='s_ilu_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  trans_ = psb_toupper(trans)
+  select case(trans_)
+  case('N')
+  case('T','C')
+  case default
+    call psb_errpush(psb_err_iarg_invalid_i_,name)
+    goto 9999
+  end select
+
+  n_row = desc_data%get_local_rows()
+  n_col = desc_data%get_local_cols()
+
+  if (n_col <= size(work)) then 
+    ww => work(1:n_col)
+    if ((4*n_col+n_col) <= size(work)) then 
+      aux => work(n_col+1:)
+    else
+      allocate(aux(4*n_col),stat=info)
+      if (info /= psb_success_) then 
+        info=psb_err_alloc_request_
+        call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
+             & a_err='real(psb_spk_)')
+        goto 9999      
+      end if
+    endif
+  else
+    allocate(ww(n_col),aux(4*n_col),stat=info)
+    if (info /= psb_success_) then 
+      info=psb_err_alloc_request_
+      call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
+           & a_err='real(psb_spk_)')
+      goto 9999      
+    end if
+  endif
+
+  select case(trans_)
+  case('N')
+    call psb_spsm(sone,sv%l,x,szero,ww,desc_data,info,&
+         & trans=trans_,scale='L',diag=sv%d,choice=psb_none_,work=aux)
+
+    if (info == psb_success_) call psb_spsm(alpha,sv%u,ww,beta,y,desc_data,info,&
+         & trans=trans_,scale='U',choice=psb_none_, work=aux)
+
+  case('T')
+    call psb_spsm(sone,sv%u,x,szero,ww,desc_data,info,&
+         & trans=trans_,scale='L',diag=sv%d,choice=psb_none_,work=aux)
+    if (info == psb_success_) call psb_spsm(alpha,sv%l,ww,beta,y,desc_data,info,&
+         & trans=trans_,scale='U',choice=psb_none_,work=aux)
+  case('C')
+    ! For real this is the same of T but in the future we will move to
+    ! a preprocessed version, so we need a placeholder
+    call psb_spsm(sone,sv%u,x,szero,ww,desc_data,info,&
+         & trans=trans_,scale='L',diag=sv%d,choice=psb_none_,work=aux)
+    if (info == psb_success_) call psb_spsm(alpha,sv%l,ww,beta,y,desc_data,info,&
+         & trans=trans_,scale='U',choice=psb_none_,work=aux)
+  case default
+    call psb_errpush(psb_err_internal_error_,name,a_err='Invalid TRANS in ILU subsolve')
+    goto 9999
+  end select
+
+
+  if (info /= psb_success_) then
+
+    call psb_errpush(psb_err_internal_error_,name,a_err='Error in subsolve')
+    goto 9999
+  endif
+
+  if (n_col <= size(work)) then 
+    if ((4*n_col+n_col) <= size(work)) then 
+    else
+      deallocate(aux)
+    endif
+  else
+    deallocate(ww,aux)
+  endif
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_s_ilu_solver_apply
+
+subroutine mld_s_ilu_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
+
+  use psb_base_mod
+  use mld_s_ilu_solver, mld_protect_name => mld_s_ilu_solver_bld
+
+  Implicit None
+
+  ! Arguments
+  type(psb_sspmat_type), intent(in), target           :: a
+  Type(psb_desc_type), Intent(in)                     :: desc_a 
+  class(mld_s_ilu_solver_type), intent(inout)         :: sv
+  character, intent(in)                               :: upd
+  integer, intent(out)                                :: info
+  type(psb_sspmat_type), intent(in), target, optional :: b
+  class(psb_s_base_sparse_mat), intent(in), optional  :: amold
+  class(psb_s_base_vect_type), intent(in), optional   :: vmold
+  ! Local variables
+  integer :: n_row,n_col, nrow_a, nztota
+  real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
+  integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
+  character(len=20)  :: name='s_ilu_solver_bld', ch_err
+
+  info=psb_success_
+  call psb_erractionsave(err_act)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  ictxt       = desc_a%get_context()
+  call psb_info(ictxt, me, np)
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),' start'
+
+
+  n_row  = desc_a%get_local_rows()
+
+  if (psb_toupper(upd) == 'F') then 
+    nrow_a = a%get_nrows()
+    nztota = a%get_nzeros()
+    if (present(b)) then 
+      nztota = nztota + b%get_nzeros()
+    end if
+
+    call sv%l%csall(n_row,n_row,info,nztota)
+    if (info == psb_success_) call sv%u%csall(n_row,n_row,info,nztota)
+    if(info /= psb_success_) then
+      info=psb_err_from_subroutine_
+      ch_err='psb_sp_all'
+      call psb_errpush(info,name,a_err=ch_err)
+      goto 9999
+    end if
+
+    if (allocated(sv%d)) then 
+      if (size(sv%d) < n_row) then 
+        deallocate(sv%d)
+      endif
+    endif
+    if (.not.allocated(sv%d))  allocate(sv%d(n_row),stat=info)
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
+      goto 9999      
+    endif
+
+
+    select case(sv%fact_type)
+
+    case (mld_ilu_t_)
+      !
+      ! ILU(k,t)
+      !
+      select case(sv%fill_in)
+
+      case(:-1) 
+        ! Error: fill-in <= -1
+        call psb_errpush(psb_err_input_value_invalid_i_,&
+             & name,i_err=(/3,sv%fill_in,0,0,0/))
+        goto 9999
+
+      case(0:)
+        ! Fill-in >= 0
+        call mld_ilut_fact(sv%fill_in,sv%thresh,&
+             & a, sv%l,sv%u,sv%d,info,blck=b)
+      end select
+      if(info /= psb_success_) then
+        info=psb_err_from_subroutine_
+        ch_err='mld_ilut_fact'
+        call psb_errpush(info,name,a_err=ch_err)
+        goto 9999
+      end if
+
+    case(mld_ilu_n_,mld_milu_n_) 
+      !
+      ! ILU(k) and MILU(k)
+      !
+      select case(sv%fill_in)
+      case(:-1) 
+        ! Error: fill-in <= -1
+        call psb_errpush(psb_err_input_value_invalid_i_,&
+             & name,i_err=(/3,sv%fill_in,0,0,0/))
+        goto 9999
+      case(0)
+        ! Fill-in 0
+        ! Separate implementation of ILU(0) for better performance.
+        ! There seems to be a problem with the separate implementation of MILU(0),
+        ! contained into mld_ilu0_fact. This must be investigated. For the time being,
+        ! resort to the implementation of MILU(k) with k=0.
+        if (sv%fact_type == mld_ilu_n_) then 
+          call mld_ilu0_fact(sv%fact_type,a,sv%l,sv%u,&
+               & sv%d,info,blck=b,upd=upd)
+        else
+          call mld_iluk_fact(sv%fill_in,sv%fact_type,&
+               & a,sv%l,sv%u,sv%d,info,blck=b)
+        endif
+      case(1:)
+        ! Fill-in >= 1
+        ! The same routine implements both ILU(k) and MILU(k)
+        call mld_iluk_fact(sv%fill_in,sv%fact_type,&
+             & a,sv%l,sv%u,sv%d,info,blck=b)
+      end select
+      if (info /= psb_success_) then
+        info=psb_err_from_subroutine_
+        ch_err='mld_iluk_fact'
+        call psb_errpush(info,name,a_err=ch_err)
+        goto 9999
+      end if
+
+    case default
+      ! If we end up here, something was wrong up in the call chain. 
+      info = psb_err_input_value_invalid_i_
+      call psb_errpush(psb_err_input_value_invalid_i_,name,&
+           & i_err=(/3,sv%fact_type,0,0,0/))
+      goto 9999
+
+    end select
+  else
+    ! Here we should add checks for reuse of L and U.
+    ! For the time being just throw an error. 
+    info = 31
+    call psb_errpush(info, name,&
+         & i_err=(/3,0,0,0,0/),a_err=upd)
+    goto 9999 
+
+    !
+    ! What is an update of a factorization??
+    ! A first attempt could be to reuse EXACTLY the existing indices
+    ! as if it was an ILU(0) (since, effectively, the sparsity pattern
+    ! should not grow beyond what is already there).
+    !  
+    call mld_ilu0_fact(sv%fact_type,a,&
+         & sv%l,sv%u,&
+         & sv%d,info,blck=b,upd=upd)
+
+  end if
+
+  call sv%l%set_asb()
+  call sv%l%trim()
+  call sv%u%set_asb()
+  call sv%u%trim()
+  call sv%dv%bld(sv%d,mold=vmold)
+
+  if (present(amold)) then 
+    call sv%l%cscnv(info,mold=amold)
+    call sv%u%cscnv(info,mold=amold)
+  end if
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),' end'
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_ilu_solver_bld
+

mlprec/mld_s_onelev_impl.f90

@@ -0,0 +1,459 @@
+!!$
+!!$ 
+!!$                           MLD2P4  version 2.0
+!!$  MultiLevel Domain Decomposition Parallel Preconditioners Package
+!!$             based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!!$  
+!!$  (C) Copyright 2008,2009,2010
+!!$
+!!$                      Salvatore Filippone  University of Rome Tor Vergata
+!!$                      Alfredo Buttari      CNRS-IRIT, Toulouse
+!!$                      Pasqua D'Ambra       ICAR-CNR, Naples
+!!$                      Daniela di Serafino  Second University of Naples
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the MLD2P4 group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$
+
+!
+! Subroutine: mld_file_onelev_descr
+! Version: real
+!
+!  This routine prints a description of the preconditioner to the standard 
+!  output or to a file. It must be called after the preconditioner has been
+!  built by mld_precbld.
+!
+! Arguments:
+!  p       -  type(mld_Tprec_type), input.
+!             The preconditioner data structure to be printed out.
+!  info    -  integer, output.
+!             error code.
+!  iout    -  integer, input, optional.
+!             The id of the file where the preconditioner description
+!             will be printed. If iout is not present, then the standard
+!             output is condidered.
+!
+subroutine mld_s_base_onelev_descr(lv,il,nl,info,iout)
+  use psb_base_mod
+  use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_descr
+  Implicit None
+  ! Arguments
+  class(mld_sonelev_type), intent(in) :: lv
+  integer, intent(in)                 :: il,nl
+  integer, intent(out)                :: info
+  integer, intent(in), optional       :: iout
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_s_base_onelev_descr'
+  integer      :: iout_
+  logical      :: coarse
+
+
+  call psb_erractionsave(err_act)
+
+
+  coarse = (il==nl)
+
+  if (present(iout)) then 
+    iout_ = iout
+  else 
+    iout_ = 6
+  end if
+
+  write(iout_,*) 
+  if (il == 2) then 
+    call lv%parms%mldescr(iout_,info)
+    write(iout_,*) 
+  end if
+
+  if (coarse)  then 
+    write(iout_,*) ' Level ',il,' (coarsest)'
+  else
+    write(iout_,*) ' Level ',il
+  end if
+
+  call lv%parms%descr(iout_,info,coarse=coarse)
+
+  if (nl > 1) then 
+    if (allocated(lv%map%naggr)) then
+      write(iout_,*) '  Size of coarse matrix: ', &
+           &  sum(lv%map%naggr(:))
+      write(iout_,*) '  Sizes of aggregates: ', &
+           &  lv%map%naggr(:)
+    end if
+  end if
+
+  if (coarse.and.allocated(lv%sm)) &
+       & call lv%sm%descr(info,iout=iout_,coarse=coarse)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_onelev_descr
+
+
+!
+! Subroutines: mld_T_onelev_precfree
+! Version: real
+!
+!  These routines deallocate the mld_Tonelev_type 
+!
+! Arguments:
+!  p       -  type(mld_Tonelev_type), input.
+!             The data structure to be deallocated.
+!  info    -  integer, output.
+!             error code.
+!
+subroutine mld_s_base_onelev_free(lv,info)
+  use psb_base_mod
+  use mld_sonelev_mod, mld_protect_name =>:  mld_T_onelev_precfree
+  implicit none 
+
+  class(mld_sonelev_type), intent(inout) :: lv
+  integer, intent(out)                :: info
+  integer :: i
+
+  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. 
+  call lv%sm%free(info)
+
+  call lv%ac%free()
+  if (psb_is_ok_desc(lv%desc_ac)) &
+       & call psb_cdfree(lv%desc_ac,info)
+  call lv%map%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) 
+
+  call lv%nullify()
+
+end subroutine mld_s_base_onelev_free
+
+!
+! Onelevel checks. 
+! The number of Jacobi sweeps to be applied is not
+! tied to the Jacobi smoother: logically, you have
+! a smoother and you can choose to apply it any number
+! of times you like. 
+!
+subroutine mld_s_base_onelev_check(lv,info)
+  use psb_base_mod
+  use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_check
+
+  Implicit None
+
+  ! Arguments
+  class(mld_sonelev_type), intent(inout) :: lv 
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='s_base_onelev_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  call mld_check_def(lv%parms%sweeps,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+  call mld_check_def(lv%parms%sweeps_pre,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+  call mld_check_def(lv%parms%sweeps_post,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+
+
+  if (allocated(lv%sm)) then 
+    call lv%sm%check(info)
+  else 
+    info=3111
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_onelev_check
+
+
+! 
+! Set routines:
+! Parameters belonging here are:
+!   Number of smoothing sweeps;
+!   Smoother position;
+!   Aggregation related parameters
+!   Record request on coarse level solver,
+!    for checks on solver vs. smoother nomenclature
+!    reconciliation. 
+! 
+subroutine mld_s_base_onelev_seti(lv,what,val,info)
+  use psb_base_mod
+  use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_seti
+
+  Implicit None
+
+  ! Arguments
+  class(mld_sonelev_type), intent(inout) :: lv 
+  integer, intent(in)                          :: what 
+  integer, intent(in)                          :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='s_base_onelev_seti'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  select case (what) 
+
+  case (mld_smoother_sweeps_)
+    lv%parms%sweeps      = val
+    lv%parms%sweeps_pre  = val
+    lv%parms%sweeps_post = val
+
+  case (mld_smoother_sweeps_pre_)
+    lv%parms%sweeps_pre  = val
+
+  case (mld_smoother_sweeps_post_)
+    lv%parms%sweeps_post = val
+
+  case (mld_ml_type_)
+    lv%parms%ml_type       = val
+
+  case (mld_aggr_alg_)
+    lv%parms%aggr_alg      = val
+
+  case (mld_aggr_kind_)
+    lv%parms%aggr_kind     = val
+
+  case (mld_coarse_mat_)
+    lv%parms%coarse_mat    = val
+
+  case (mld_smoother_pos_)
+    lv%parms%smoother_pos  = val
+
+  case (mld_aggr_omega_alg_)
+    lv%parms%aggr_omega_alg= val
+
+  case (mld_aggr_eig_)
+    lv%parms%aggr_eig      = val
+
+  case (mld_aggr_filter_)
+    lv%parms%aggr_filter   = val
+
+  case (mld_coarse_solve_)
+    lv%parms%coarse_solve    = val
+
+  case default
+    if (allocated(lv%sm)) then 
+      call lv%sm%set(what,val,info)
+    end if
+    if (info /= psb_success_) goto 9999
+  end select
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_onelev_seti
+
+subroutine mld_s_base_onelev_setc(lv,what,val,info)
+  use psb_base_mod
+  use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_setc
+
+  Implicit None
+
+  ! Arguments
+  class(mld_sonelev_type), intent(inout) :: lv 
+  integer, intent(in)                            :: what 
+  character(len=*), intent(in)                   :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='s_base_onelev_setc'
+  integer :: ival 
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  call mld_stringval(val,ival,info)
+  if (info == psb_success_) call lv%set(what,ival,info)
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_onelev_setc
+
+subroutine mld_s_base_onelev_setr(lv,what,val,info)
+  use psb_base_mod
+  use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_setr
+
+  Implicit None
+
+  ! Arguments
+  class(mld_sonelev_type), intent(inout) :: lv 
+  integer, intent(in)                            :: what 
+  real(psb_spk_), intent(in)                     :: val
+  integer, intent(out)                           :: info
+  Integer :: err_act
+  character(len=20)  :: name='s_base_onelev_setr'
+
+  call psb_erractionsave(err_act)
+
+
+  info = psb_success_
+
+  select case (what) 
+
+  case (mld_aggr_omega_val_)
+    lv%parms%aggr_omega_val= val
+
+  case (mld_aggr_thresh_)
+    lv%parms%aggr_thresh   = val
+
+  case default
+    if (allocated(lv%sm)) then 
+      call lv%sm%set(what,val,info)
+    end if
+    if (info /= psb_success_) goto 9999
+  end select
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_s_base_onelev_setr
+
+!
+! Dump on file: can be fine-tuned to include the (aggregated) matrix
+! as well as smoother and solver. 
+!
+subroutine mld_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
+  use psb_base_mod
+  use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_dump
+  implicit none 
+  class(mld_sonelev_type), intent(in) :: lv
+  integer, intent(in)              :: level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: ac, rp, smoother, solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: ac_, rp_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_lev_s"
+  end if
+
+  if (associated(lv%base_desc)) then 
+    icontxt = lv%base_desc%get_context()
+    call psb_info(icontxt,iam,np)
+  else 
+    icontxt = -1 
+    iam     = -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
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  if (level >= 2) then 
+    if (ac_) then 
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%ac%print(fname,head=head)
+    end if
+    if (rp_) then 
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%map%map_X2Y%print(fname,head=head)
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%map%map_Y2X%print(fname,head=head)
+    end if
+  end if
+  if (allocated(lv%sm)) &
+       & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver)
+
+end subroutine mld_s_base_onelev_dump
+
+

mlprec/mld_s_onelev_mod.f90

@@ -57,7 +57,7 @@ module mld_s_onelev_mod
   use mld_base_prec_type
   use mld_s_base_smoother_mod
   use psb_base_mod, only : psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
-       & psb_slinmap_type
+       & psb_slinmap_type, psb_spk_, psb_long_int_k_, psb_desc_type
   !
   !
   ! Type: mld_Tonelev_type.
@@ -127,31 +127,112 @@ module mld_s_onelev_mod
     type(psb_desc_type), pointer    :: base_desc => null() 
     type(psb_slinmap_type)          :: map
   contains
-    procedure, pass(lv) :: descr   => s_base_onelev_descr
+    procedure, pass(lv) :: descr   => mld_s_base_onelev_descr
     procedure, pass(lv) :: default => s_base_onelev_default
-    procedure, pass(lv) :: free    => s_base_onelev_free
+    procedure, pass(lv) :: free    => mld_s_base_onelev_free
     procedure, pass(lv) :: nullify => s_base_onelev_nullify
-    procedure, pass(lv) :: check => s_base_onelev_check
+    procedure, pass(lv) :: check => mld_s_base_onelev_check
-    procedure, pass(lv) :: dump  => s_base_onelev_dump
+    procedure, pass(lv) :: dump  => mld_s_base_onelev_dump
-    procedure, pass(lv) :: seti  => s_base_onelev_seti
+    procedure, pass(lv) :: seti  => mld_s_base_onelev_seti
-    procedure, pass(lv) :: setr  => s_base_onelev_setr
+    procedure, pass(lv) :: setr  => mld_s_base_onelev_setr
-    procedure, pass(lv) :: setc  => s_base_onelev_setc
+    procedure, pass(lv) :: setc  => mld_s_base_onelev_setc
     generic, public     :: set   => seti, setr, setc
     procedure, pass(lv) :: sizeof => s_base_onelev_sizeof
     procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros
   end type mld_sonelev_type
 
-  private :: s_base_onelev_seti, s_base_onelev_setc, &
+  private :: s_base_onelev_default, s_base_onelev_sizeof, &
-       &  s_base_onelev_setr, s_base_onelev_check, &
+       &  s_base_onelev_nullify, s_base_onelev_get_nzeros
-       &  s_base_onelev_default, s_base_onelev_dump, &
+
-       &  s_base_onelev_descr,  s_base_onelev_sizeof, &
+
-       &  s_base_onelev_free,  s_base_onelev_nullify,&
+
-       &  s_base_onelev_get_nzeros
+  interface mld_s_base_onelev_descr
-
+    subroutine mld_s_base_onelev_descr(lv,il,nl,info,iout)
-
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
-  interface mld_nullify_onelevprec
+           & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type
-    module procedure  mld_nullify_d_onelevprec
+      Implicit None
-  end interface
+      ! Arguments
+      class(mld_sonelev_type), intent(in) :: lv
+      integer, intent(in)                 :: il,nl
+      integer, intent(out)                :: info
+      integer, intent(in), optional       :: iout
+    end subroutine mld_s_base_onelev_descr
+  end interface mld_s_base_onelev_descr
+  
+  interface mld_s_base_onelev_free
+    subroutine mld_s_base_onelev_free(lv,info)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type
+      implicit none 
+      
+      class(mld_sonelev_type), intent(inout) :: lv
+      integer, intent(out)                :: info
+    end subroutine mld_s_base_onelev_free
+  end interface mld_s_base_onelev_free
+  
+  interface mld_s_base_onelev_check
+    subroutine mld_s_base_onelev_check(lv,info)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      ! Arguments
+      class(mld_sonelev_type), intent(inout) :: lv 
+      integer, intent(out)                   :: info
+    end subroutine mld_s_base_onelev_check
+  end interface mld_s_base_onelev_check
+  
+  interface mld_s_base_onelev_seti
+    subroutine mld_s_base_onelev_seti(lv,what,val,info)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_sonelev_type), intent(inout) :: lv 
+      integer, intent(in)                          :: what 
+      integer, intent(in)                          :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_s_base_onelev_seti
+  end interface mld_s_base_onelev_seti
+  
+  interface mld_s_base_onelev_setc
+    subroutine mld_s_base_onelev_setc(lv,what,val,info)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      ! Arguments
+      class(mld_sonelev_type), intent(inout) :: lv 
+      integer, intent(in)                            :: what 
+      character(len=*), intent(in)                   :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_s_base_onelev_setc
+  end interface mld_s_base_onelev_setc
+  
+  interface mld_s_base_onelev_setr
+    subroutine mld_s_base_onelev_setr(lv,what,val,info)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      
+      class(mld_sonelev_type), intent(inout) :: lv 
+      integer, intent(in)                            :: what 
+      real(psb_spk_), intent(in)                     :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_s_base_onelev_setr
+  end interface mld_s_base_onelev_setr
+
+  interface mld_s_base_onelev_dump
+    subroutine mld_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
+      import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+           & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type
+      implicit none 
+      class(mld_sonelev_type), intent(in) :: lv
+      integer, intent(in)              :: level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: ac, rp, smoother, solver
+    end subroutine mld_s_base_onelev_dump
+  end interface mld_s_base_onelev_dump
   
   
 contains
@@ -184,137 +265,6 @@ contains
   end function s_base_onelev_sizeof
 
 
-  !
-  ! Subroutine: mld_file_onelev_descr
-  ! Version: real
-  !
-  !  This routine prints a description of the preconditioner to the standard 
-  !  output or to a file. It must be called after the preconditioner has been
-  !  built by mld_precbld.
-  !
-  ! Arguments:
-  !  p       -  type(mld_Tprec_type), input.
-  !             The preconditioner data structure to be printed out.
-  !  info    -  integer, output.
-  !             error code.
-  !  iout    -  integer, input, optional.
-  !             The id of the file where the preconditioner description
-  !             will be printed. If iout is not present, then the standard
-  !             output is condidered.
-  !
-  subroutine s_base_onelev_descr(lv,il,nl,info,iout)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_sonelev_type), intent(in) :: lv
-    integer, intent(in)                 :: il,nl
-    integer, intent(out)                :: info
-    integer, intent(in), optional       :: iout
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_s_base_onelev_descr'
-    integer      :: iout_
-    logical      :: coarse
-
-
-    call psb_erractionsave(err_act)
-
-
-    coarse = (il==nl)
-
-    if (present(iout)) then 
-      iout_ = iout
-    else 
-      iout_ = 6
-    end if
-    
-    write(iout_,*) 
-    if (il == 2) then 
-      call lv%parms%mldescr(iout_,info)
-      write(iout_,*) 
-    end if
-
-    if (coarse)  then 
-      write(iout_,*) ' Level ',il,' (coarsest)'
-    else
-      write(iout_,*) ' Level ',il
-    end if
-
-    call lv%parms%descr(iout_,info,coarse=coarse)
-        
-    if (nl > 1) then 
-      if (allocated(lv%map%naggr)) then
-        write(iout_,*) '  Size of coarse matrix: ', &
-             &  sum(lv%map%naggr(:))
-        write(iout_,*) '  Sizes of aggregates: ', &
-             &  lv%map%naggr(:)
-      end if
-    end if
-
-    if (coarse.and.allocated(lv%sm)) &
-         & call lv%sm%descr(info,iout=iout_,coarse=coarse)
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_onelev_descr
-
-
-  !
-  ! Subroutines: mld_T_onelev_precfree
-  ! Version: real
-  !
-  !  These routines deallocate the mld_Tonelev_type 
-  !
-  ! Arguments:
-  !  p       -  type(mld_Tonelev_type), input.
-  !             The data structure to be deallocated.
-  !  info    -  integer, output.
-  !             error code.
-  !
-  subroutine s_base_onelev_free(lv,info)
-    use psb_base_mod
-    implicit none 
-
-    class(mld_sonelev_type), intent(inout) :: lv
-    integer, intent(out)                :: info
-    integer :: i
-
-    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. 
-    call lv%sm%free(info)
-    
-    call lv%ac%free()
-    if (psb_is_ok_desc(lv%desc_ac)) &
-         & call psb_cdfree(lv%desc_ac,info)
-    call lv%map%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) 
-
-    call lv%nullify()
-
-  end subroutine s_base_onelev_free
-
-
   subroutine s_base_onelev_nullify(lv)
     implicit none 
 
@@ -325,69 +275,6 @@ contains
 
   end subroutine s_base_onelev_nullify
 
-
-  subroutine mld_nullify_d_onelevprec(p)
-    implicit none 
-
-    type(mld_sonelev_type), intent(inout) :: p
-
-    nullify(p%base_a) 
-    nullify(p%base_desc) 
-
-  end subroutine mld_nullify_d_onelevprec
-
-  !
-  ! Onelevel checks. 
-  ! The number of Jacobi sweeps to be applied is not
-  ! tied to the Jacobi smoother: logically, you have
-  ! a smoother and you can choose to apply it any number
-  ! of times you like. 
-  !
-  subroutine s_base_onelev_check(lv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_sonelev_type), intent(inout) :: lv 
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    call mld_check_def(lv%parms%sweeps,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-    call mld_check_def(lv%parms%sweeps_pre,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-    call mld_check_def(lv%parms%sweeps_post,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-
-    
-    if (allocated(lv%sm)) then 
-      call lv%sm%check(info)
-    else 
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_onelev_check
-
   !
   ! Multilevel defaults: 
   !  multiplicative vs. additive ML framework;
@@ -400,8 +287,6 @@ contains
 
   subroutine s_base_onelev_default(lv)
 
-    use psb_base_mod
-
     Implicit None
 
     ! Arguments
@@ -427,241 +312,4 @@ contains
 
   end subroutine s_base_onelev_default
 
-  ! 
-  ! Set routines:
-  ! Parameters belonging here are:
-  !   Number of smoothing sweeps;
-  !   Smoother position;
-  !   Aggregation related parameters
-  !   Record request on coarse level solver,
-  !    for checks on solver vs. smoother nomenclature
-  !    reconciliation. 
-  ! 
-  subroutine s_base_onelev_seti(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_sonelev_type), intent(inout) :: lv 
-    integer, intent(in)                          :: what 
-    integer, intent(in)                          :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_seti'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    select case (what) 
-
-    case (mld_smoother_sweeps_)
-      lv%parms%sweeps      = val
-      lv%parms%sweeps_pre  = val
-      lv%parms%sweeps_post = val
-
-    case (mld_smoother_sweeps_pre_)
-      lv%parms%sweeps_pre  = val
-
-    case (mld_smoother_sweeps_post_)
-      lv%parms%sweeps_post = val
-
-    case (mld_ml_type_)
-      lv%parms%ml_type       = val
-
-    case (mld_aggr_alg_)
-      lv%parms%aggr_alg      = val
-
-    case (mld_aggr_kind_)
-      lv%parms%aggr_kind     = val
-
-    case (mld_coarse_mat_)
-      lv%parms%coarse_mat    = val
-
-    case (mld_smoother_pos_)
-      lv%parms%smoother_pos  = val
-
-    case (mld_aggr_omega_alg_)
-      lv%parms%aggr_omega_alg= val
-
-    case (mld_aggr_eig_)
-      lv%parms%aggr_eig      = val
-
-    case (mld_aggr_filter_)
-      lv%parms%aggr_filter   = val
-
-    case (mld_coarse_solve_)
-      lv%parms%coarse_solve    = val
-
-    case default
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info)
-      end if
-      if (info /= psb_success_) goto 9999
-    end select
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_onelev_seti
-
-  subroutine s_base_onelev_setc(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_sonelev_type), intent(inout) :: lv 
-    integer, intent(in)                            :: what 
-    character(len=*), intent(in)                   :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_setc'
-    integer :: ival 
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    call mld_stringval(val,ival,info)
-    if (info == psb_success_) call lv%set(what,ival,info)
-
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_onelev_setc
-  
-  subroutine s_base_onelev_setr(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_sonelev_type), intent(inout) :: lv 
-    integer, intent(in)                            :: what 
-    real(psb_spk_), intent(in)                     :: val
-    integer, intent(out)                           :: info
-    Integer :: err_act
-    character(len=20)  :: name='d_base_onelev_setr'
-
-    call psb_erractionsave(err_act)
-
-
-    info = psb_success_
-    
-    select case (what) 
-
-    case (mld_aggr_omega_val_)
-      lv%parms%aggr_omega_val= val
-   
-    case (mld_aggr_thresh_)
-      lv%parms%aggr_thresh   = val
-
-    case default
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info)
-      end if
-      if (info /= psb_success_) goto 9999
-    end select
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine s_base_onelev_setr
-
-  !
-  ! Dump on file: can be fine-tuned to include the (aggregated) matrix
-  ! as well as smoother and solver. 
-  !
-  subroutine s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_sonelev_type), intent(in) :: lv
-    integer, intent(in)              :: level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: ac, rp, smoother, solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: ac_, rp_
-    !  len of prefix_ 
-
-    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 
-      icontxt = lv%base_desc%get_context()
-      call psb_info(icontxt,iam,np)
-    else 
-      icontxt = -1 
-      iam     = -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
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    if (level >= 2) then 
-      if (ac_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%ac%print(fname,head=head)
-      end if
-      if (rp_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%map%map_X2Y%print(fname,head=head)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%map%map_Y2X%print(fname,head=head)
-      end if
-    end if
-    if (allocated(lv%sm)) &
-         & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver)
-
-  end subroutine s_base_onelev_dump
-
-
 end module mld_s_onelev_mod

mlprec/mld_z_base_smoother_impl.f90

@@ -0,0 +1,481 @@
+!!$
+!!$ 
+!!$                           MLD2P4  version 2.0
+!!$  MultiLevel Domain Decomposition Parallel Preconditioners Package
+!!$             based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!!$  
+!!$  (C) Copyright 2008,2009,2010
+!!$
+!!$                      Salvatore Filippone  University of Rome Tor Vergata
+!!$                      Alfredo Buttari      CNRS-IRIT, Toulouse
+!!$                      Pasqua D'Ambra       ICAR-CNR, Naples
+!!$                      Daniela di Serafino  Second University of Naples
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the MLD2P4 group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 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.
+!!$ 
+!!$
+
+!
+! Apply: comes in two versions, on plain arrays or on encapsulated
+! vectors.
+! This basic version just applies the local solver, whatever that
+! is. 
+!
+
+subroutine mld_z_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name =>  mld_z_base_smoother_apply
+  implicit none 
+  type(psb_desc_type), intent(in)             :: desc_data
+  class(mld_z_base_smoother_type), intent(in) :: sm
+  complex(psb_dpk_),intent(inout)                :: x(:)
+  complex(psb_dpk_),intent(inout)                :: y(:)
+  complex(psb_dpk_),intent(in)                   :: alpha,beta
+  character(len=1),intent(in)                 :: trans
+  integer, intent(in)                         :: sweeps
+  complex(psb_dpk_),target, intent(inout)        :: work(:)
+  integer, intent(out)                        :: info
+
+  Integer           :: err_act
+  character(len=20) :: name='z_base_smoother_apply'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
+  else
+    info = 1121
+  endif
+  if (info /= psb_success_) then 
+    call psb_errpush(info,name)
+    goto 9999 
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_z_base_smoother_apply
+
+subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
+     &  trans,sweeps,work,info)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name =>  mld_z_base_smoother_apply_vect
+  implicit none 
+  type(psb_desc_type), intent(in)                :: desc_data
+  class(mld_z_base_smoother_type), intent(inout) :: sm
+  type(psb_z_vect_type),intent(inout)            :: x
+  type(psb_z_vect_type),intent(inout)            :: y
+  complex(psb_dpk_),intent(in)                      :: alpha,beta
+  character(len=1),intent(in)                    :: trans
+  integer, intent(in)                            :: sweeps
+  complex(psb_dpk_),target, intent(inout)           :: work(:)
+  integer, intent(out)                           :: info
+
+  Integer           :: err_act
+  character(len=20) :: name='z_base_smoother_apply'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
+  else
+    info = 1121
+  endif
+  if (info /= psb_success_) then 
+    call psb_errpush(info,name)
+    goto 9999 
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_z_base_smoother_apply_vect
+
+!
+! Check:
+! 1. Check that we do have a solver object
+! 2. Call its check method
+!
+
+subroutine mld_z_base_smoother_check(sm,info)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name =>  mld_z_base_smoother_check
+  Implicit None
+
+  ! Arguments
+  class(mld_z_base_smoother_type), intent(inout) :: sm 
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='z_base_smoother_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%check(info)
+  else 
+    info=3111
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_smoother_check
+
+!
+! Set methods: the come in multiple versions according
+! to whether we are setting with integer, real or character
+! input.
+! The basic rule is: if the input refers to a parameter
+! of the smoother, use it, otherwise pass it to the
+! solver object for further processing.
+! Since there are no parameters in the base smoother
+! we just pass everything to the solver object. 
+!
+subroutine mld_z_base_smoother_seti(sm,what,val,info)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name =>  mld_z_base_smoother_seti
+  Implicit None
+  ! Arguments
+  class(mld_z_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  integer, intent(in)                            :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='z_base_smoother_seti'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_smoother_seti
+
+subroutine mld_z_base_smoother_setc(sm,what,val,info)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name =>  mld_z_base_smoother_setc
+  Implicit None
+
+  ! Arguments
+  class(mld_z_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  character(len=*), intent(in)                   :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='z_base_smoother_setc'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_smoother_setc
+
+subroutine mld_z_base_smoother_setr(sm,what,val,info)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name =>  mld_z_base_smoother_setr
+  Implicit None
+
+  ! Arguments
+  class(mld_z_base_smoother_type), intent(inout) :: sm 
+  integer, intent(in)                            :: what 
+  real(psb_dpk_), intent(in)                     :: val
+  integer, intent(out)                           :: info
+  Integer :: err_act
+  character(len=20)  :: name='z_base_smoother_setr'
+
+  call psb_erractionsave(err_act)
+
+
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%set(what,val,info)
+  end if
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_smoother_setr
+
+
+!
+! Build method.
+! At base level we only have to pass data to the inner solver. 
+! AMOLD/VMOLD allow to have any relevant sparse matrix or vector
+! to be stored in a given format. This is essential e.g.
+! when dealing  with GPUs. 
+!
+subroutine mld_z_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name =>  mld_z_base_smoother_bld
+  Implicit None
+
+  ! Arguments
+  type(psb_zspmat_type), intent(in), target      :: a
+  Type(psb_desc_type), Intent(in)                :: desc_a 
+  class(mld_z_base_smoother_type), intent(inout) :: sm 
+  character, intent(in)                          :: upd
+  integer, intent(out)                           :: info
+  class(psb_z_base_sparse_mat), intent(in), optional :: amold
+  class(psb_z_base_vect_type), intent(in), optional  :: vmold
+  Integer           :: err_act
+  character(len=20) :: name='z_base_smoother_bld'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+  if (allocated(sm%sv)) then 
+    call sm%sv%build(a,desc_a,upd,info,amold=amold,vmold=vmold)
+  else
+    info = 1121
+    call psb_errpush(info,name)
+  endif
+  if (info /= psb_success_) goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_smoother_bld
+
+!
+! Free method (aka destructor).
+! In most cases we could do without; however
+! for cases where there are data objects allocated outside
+! of the Fortran RTE we need to free them explicitly.
+!
+! Even in that case, we could do without this if FINAL
+! subroutines were supported, which is not the case
+
+! in GNU Fortran up to 4.7. 
+!
+subroutine mld_z_base_smoother_free(sm,info)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name => s
+  Implicit None
+
+  ! Arguments
+  class(mld_z_base_smoother_type), intent(inout) :: sm
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='z_base_smoother_free'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (allocated(sm%sv)) then 
+    call sm%sv%free(info)
+  end if
+  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
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_smoother_free
+
+!
+! Print a description
+!
+
+subroutine mld_z_base_smoother_descr(sm,info,iout,coarse)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name =>  mld_z_base_smoother_descr
+  Implicit None
+
+  ! Arguments
+  class(mld_z_base_smoother_type), intent(in) :: sm
+  integer, intent(out)                        :: info
+  integer, intent(in), optional               :: iout
+  logical, intent(in), optional               :: coarse
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_z_base_smoother_descr'
+  integer :: iout_
+  logical      :: coarse_
+
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  if (present(coarse)) then 
+    coarse_ = coarse
+  else
+    coarse_ = .false.
+  end if
+  if (present(iout)) then 
+    iout_ = iout
+  else 
+    iout_ = 6
+  end if
+
+  if (.not.coarse_) &
+       &  write(iout_,*) 'Base smoother with local solver'
+  if (allocated(sm%sv)) then 
+    call sm%sv%descr(info,iout,coarse)
+    if (info /= psb_success_) then 
+      info = psb_err_from_subroutine_ 
+      call psb_errpush(info,name,a_err='Local solver')
+      goto 9999
+    end if
+  end if
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_smoother_descr
+
+!
+! Dump 
+! to file, for debugging purposes.
+!
+subroutine mld_z_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+  use psb_base_mod
+  use mld_z_base_smoother_mod, mld_protect_name =>  mld_z_base_smoother_dmp
+  implicit none 
+  class(mld_z_base_smoother_type), intent(in) :: sm
+  integer, intent(in)              :: ictxt,level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: smoother, solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: smoother_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_smth_z"
+  end if
+
+  call psb_info(ictxt,iam,np)
+
+  if (present(smoother)) then 
+    smoother_ = smoother
+  else
+    smoother_ = .false. 
+  end if
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  ! At base level do nothing for the smoother
+  if (allocated(sm%sv)) &
+       & call sm%sv%dump(ictxt,level,info,solver=solver)
+
+end subroutine mld_z_base_smoother_dmp
+

mlprec/mld_z_base_smoother_mod.f90

@@ -54,7 +54,8 @@
 module mld_z_base_smoother_mod
 
   use mld_z_base_solver_mod
-  use psb_base_mod, only : psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type
+  use psb_base_mod, only : psb_desc_type, psb_zspmat_type, psb_long_int_k_,&
+       & psb_z_vect_type, psb_z_base_vect_type, psb_z_base_sparse_mat, psb_dpk_
   
   !
   !
@@ -91,32 +92,155 @@ module mld_z_base_smoother_mod
   type  mld_z_base_smoother_type
     class(mld_z_base_solver_type), allocatable :: sv
   contains
-    procedure, pass(sm) :: check => z_base_smoother_check
+    procedure, pass(sm) :: check => mld_z_base_smoother_check
-    procedure, pass(sm) :: dump  => z_base_smoother_dmp
+    procedure, pass(sm) :: dump  => mld_z_base_smoother_dmp
-    procedure, pass(sm) :: build => z_base_smoother_bld
+    procedure, pass(sm) :: build => mld_z_base_smoother_bld
-    procedure, pass(sm) :: apply_v => z_base_smoother_apply_vect
+    procedure, pass(sm) :: apply_v => mld_z_base_smoother_apply_vect
-    procedure, pass(sm) :: apply_a => z_base_smoother_apply
+    procedure, pass(sm) :: apply_a => mld_z_base_smoother_apply
     generic, public     :: apply => apply_a, apply_v
-    procedure, pass(sm) :: free  => z_base_smoother_free
+    procedure, pass(sm) :: free  => mld_z_base_smoother_free
-    procedure, pass(sm) :: seti  => z_base_smoother_seti
+    procedure, pass(sm) :: seti  => mld_z_base_smoother_seti
-    procedure, pass(sm) :: setc  => z_base_smoother_setc
+    procedure, pass(sm) :: setc  => mld_z_base_smoother_setc
-    procedure, pass(sm) :: setr  => z_base_smoother_setr
+    procedure, pass(sm) :: setr  => mld_z_base_smoother_setr
     generic, public     :: set   => seti, setc, setr
     procedure, pass(sm) :: default => z_base_smoother_default
-    procedure, pass(sm) :: descr =>   z_base_smoother_descr
+    procedure, pass(sm) :: descr =>   mld_z_base_smoother_descr
     procedure, pass(sm) :: sizeof =>  z_base_smoother_sizeof
     procedure, pass(sm) :: get_nzeros => z_base_smoother_get_nzeros
   end type mld_z_base_smoother_type
 
 
-  private :: z_base_smoother_bld,   z_base_smoother_apply, &
+  private :: z_base_smoother_sizeof, &
-       &  z_base_smoother_free,  z_base_smoother_seti, &
+       &  z_base_smoother_default, z_base_smoother_get_nzeros
-       &  z_base_smoother_setc,  z_base_smoother_setr,&
+
-       &  z_base_smoother_descr, z_base_smoother_sizeof, &
+
-       &  z_base_smoother_default, z_base_smoother_check, &
+
-       &  z_base_smoother_dmp, z_base_smoother_apply_vect, &
+  interface mld_z_base_smoother_apply
-       &  z_base_smoother_get_nzeros
+    subroutine mld_z_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
-
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+       & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      type(psb_desc_type), intent(in)             :: desc_data
+      class(mld_z_base_smoother_type), intent(in) :: sm
+      complex(psb_dpk_),intent(inout)                :: x(:)
+      complex(psb_dpk_),intent(inout)                :: y(:)
+      complex(psb_dpk_),intent(in)                   :: alpha,beta
+      character(len=1),intent(in)                 :: trans
+      integer, intent(in)                         :: sweeps
+      complex(psb_dpk_),target, intent(inout)        :: work(:)
+      integer, intent(out)                        :: info
+    end subroutine mld_z_base_smoother_apply
+  end interface mld_z_base_smoother_apply
+  
+  interface mld_z_base_smoother_apply_vect
+    subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
+         &  trans,sweeps,work,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      type(psb_desc_type), intent(in)                :: desc_data
+      class(mld_z_base_smoother_type), intent(inout) :: sm
+      type(psb_z_vect_type),intent(inout)            :: x
+      type(psb_z_vect_type),intent(inout)            :: y
+      complex(psb_dpk_),intent(in)                      :: alpha,beta
+      character(len=1),intent(in)                    :: trans
+      integer, intent(in)                            :: sweeps
+      complex(psb_dpk_),target, intent(inout)           :: work(:)
+      integer, intent(out)                           :: info
+    end subroutine mld_z_base_smoother_apply_vect
+  end interface mld_z_base_smoother_apply_vect
+  
+  interface mld_z_base_smoother_check
+    subroutine mld_z_base_smoother_check(sm,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      ! Arguments
+      class(mld_z_base_smoother_type), intent(inout) :: sm 
+      integer, intent(out)                   :: info
+    end subroutine mld_z_base_smoother_check
+  end interface mld_z_base_smoother_check
+  
+  interface mld_z_base_smoother_seti
+    subroutine mld_z_base_smoother_seti(sm,what,val,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      ! Arguments
+      class(mld_z_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      integer, intent(in)                            :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_z_base_smoother_seti
+  end interface mld_z_base_smoother_seti
+  
+  interface mld_z_base_smoother_setc
+    subroutine mld_z_base_smoother_setc(sm,what,val,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      class(mld_z_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      character(len=*), intent(in)                   :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_z_base_smoother_setc
+  end interface mld_z_base_smoother_setc
+  
+  interface mld_z_base_smoother_setr
+    subroutine mld_z_base_smoother_setr(sm,what,val,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      ! Arguments
+      class(mld_z_base_smoother_type), intent(inout) :: sm 
+      integer, intent(in)                            :: what 
+      real(psb_dpk_), intent(in)                     :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_z_base_smoother_setr
+  end interface mld_z_base_smoother_setr
+  
+  interface mld_z_base_smoother_bld
+    subroutine mld_z_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      ! Arguments
+      type(psb_zspmat_type), intent(in), target      :: a
+      Type(psb_desc_type), Intent(in)                :: desc_a 
+      class(mld_z_base_smoother_type), intent(inout) :: sm 
+      character, intent(in)                          :: upd
+      integer, intent(out)                           :: info
+      class(psb_z_base_sparse_mat), intent(in), optional :: amold
+      class(psb_z_base_vect_type), intent(in), optional  :: vmold
+    end subroutine mld_z_base_smoother_bld
+  end interface mld_z_base_smoother_bld
+  
+  interface mld_z_base_smoother_free
+    subroutine mld_z_base_smoother_free(sm,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      ! Arguments
+      class(mld_z_base_smoother_type), intent(inout) :: sm
+      integer, intent(out)                           :: info
+    end subroutine mld_z_base_smoother_free
+  end interface mld_z_base_smoother_free
+  
+  interface mld_z_base_smoother_descr
+    subroutine mld_z_base_smoother_descr(sm,info,iout,coarse)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      ! Arguments
+      class(mld_z_base_smoother_type), intent(in) :: sm
+      integer, intent(out)                        :: info
+      integer, intent(in), optional               :: iout
+      logical, intent(in), optional               :: coarse
+    end subroutine mld_z_base_smoother_descr
+  end interface mld_z_base_smoother_descr
+  
+  interface mld_z_base_smoother_dmp
+    subroutine mld_z_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_smoother_type
+      class(mld_z_base_smoother_type), intent(in) :: sm
+      integer, intent(in)              :: ictxt,level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: smoother, solver
+    end subroutine mld_z_base_smoother_dmp
+  end interface mld_z_base_smoother_dmp
   
 contains
   !
@@ -149,451 +273,6 @@ contains
     return
   end function z_base_smoother_sizeof
 
-
-  !
-  ! Apply: comes in two versions, on plain arrays or on encapsulated
-  ! vectors.
-  ! This basic version just applies the local solver, whatever that
-  ! is. 
-  !
-
-  subroutine z_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)             :: desc_data
-    class(mld_z_base_smoother_type), intent(in) :: sm
-    complex(psb_dpk_),intent(inout)                :: x(:)
-    complex(psb_dpk_),intent(inout)                :: y(:)
-    complex(psb_dpk_),intent(in)                   :: alpha,beta
-    character(len=1),intent(in)                 :: trans
-    integer, intent(in)                         :: sweeps
-    complex(psb_dpk_),target, intent(inout)        :: work(:)
-    integer, intent(out)                        :: info
-    
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_apply'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
-    else
-      info = 1121
-    endif
-    if (info /= psb_success_) then 
-      call psb_errpush(info,name)
-      goto 9999 
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine z_base_smoother_apply
-
-  subroutine z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
-       &  trans,sweeps,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)                :: desc_data
-    class(mld_z_base_smoother_type), intent(inout) :: sm
-    type(psb_z_vect_type),intent(inout)            :: x
-    type(psb_z_vect_type),intent(inout)            :: y
-    complex(psb_dpk_),intent(in)                      :: alpha,beta
-    character(len=1),intent(in)                    :: trans
-    integer, intent(in)                            :: sweeps
-    complex(psb_dpk_),target, intent(inout)           :: work(:)
-    integer, intent(out)                           :: info
-    
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_apply'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info)
-    else
-      info = 1121
-    endif
-    if (info /= psb_success_) then 
-      call psb_errpush(info,name)
-      goto 9999 
-    end if
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine z_base_smoother_apply_vect
-
-  !
-  ! Check:
-  ! 1. Check that we do have a solver object
-  ! 2. Call its check method
-  !
-
-  subroutine z_base_smoother_check(sm,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_smoother_type), intent(inout) :: sm 
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%check(info)
-    else 
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_smoother_check
-
-  !
-  ! Set methods: the come in multiple versions according
-  ! to whether we are setting with integer, real or character
-  ! input.
-  ! The basic rule is: if the input refers to a parameter
-  ! of the smoother, use it, otherwise pass it to the
-  ! solver object for further processing.
-  ! Since there are no parameters in the base smoother
-  ! we just pass everything to the solver object. 
-  !
-  subroutine z_base_smoother_seti(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    integer, intent(in)                            :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_seti'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_smoother_seti
-
-  subroutine z_base_smoother_setc(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    character(len=*), intent(in)                   :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_setc'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_smoother_setc
-  
-  subroutine z_base_smoother_setr(sm,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_smoother_type), intent(inout) :: sm 
-    integer, intent(in)                            :: what 
-    real(psb_dpk_), intent(in)                     :: val
-    integer, intent(out)                           :: info
-    Integer :: err_act
-    character(len=20)  :: name='d_base_smoother_setr'
-
-    call psb_erractionsave(err_act)
-
-
-    info = psb_success_
-
-    if (allocated(sm%sv)) then 
-      call sm%sv%set(what,val,info)
-    end if
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_smoother_setr
-
-
-  !
-  ! Build method.
-  ! At base level we only have to pass data to the inner solver. 
-  ! AMOLD/VMOLD allow to have any relevant sparse matrix or vector
-  ! to be stored in a given format. This is essential e.g.
-  ! when dealing  with GPUs. 
-  !
-  subroutine z_base_smoother_bld(a,desc_a,sm,upd,info,amold,vmold)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    type(psb_zspmat_type), intent(in), target      :: a
-    Type(psb_desc_type), Intent(in)                :: desc_a 
-    class(mld_z_base_smoother_type), intent(inout) :: sm 
-    character, intent(in)                          :: upd
-    integer, intent(out)                           :: info
-    class(psb_z_base_sparse_mat), intent(in), optional :: amold
-    class(psb_z_base_vect_type), intent(in), optional  :: vmold
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_bld'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-    if (allocated(sm%sv)) then 
-      call sm%sv%build(a,desc_a,upd,info,amold=amold,vmold=vmold)
-    else
-      info = 1121
-      call psb_errpush(info,name)
-    endif
-    if (info /= psb_success_) goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_smoother_bld
-
-  !
-  ! Free method (aka destructor).
-  ! In most cases we could do without; however
-  ! for cases where there are data objects allocated outside
-  ! of the Fortran RTE we need to free them explicitly.
-  !
-  ! Even in that case, we could do without this if FINAL
-  ! subroutines were supported, which is not the case
-  ! in GNU Fortran up to 4.7. 
-  !
-  subroutine z_base_smoother_free(sm,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_smoother_type), intent(inout) :: sm
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_smoother_free'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-    
-    if (allocated(sm%sv)) then 
-      call sm%sv%free(info)
-    end if
-    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
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_smoother_free
-
-  !
-  ! Print a description
-  !
-
-  subroutine z_base_smoother_descr(sm,info,iout,coarse)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_smoother_type), intent(in) :: sm
-    integer, intent(out)                        :: info
-    integer, intent(in), optional               :: iout
-    logical, intent(in), optional               :: coarse
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_z_base_smoother_descr'
-    integer :: iout_
-    logical      :: coarse_
-
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    if (present(coarse)) then 
-      coarse_ = coarse
-    else
-      coarse_ = .false.
-    end if
-    if (present(iout)) then 
-      iout_ = iout
-    else 
-      iout_ = 6
-    end if
-
-    if (.not.coarse_) &
-         &  write(iout_,*) 'Base smoother with local solver'
-    if (allocated(sm%sv)) then 
-      call sm%sv%descr(info,iout,coarse)
-      if (info /= psb_success_) then 
-        info = psb_err_from_subroutine_ 
-        call psb_errpush(info,name,a_err='Local solver')
-        goto 9999
-      end if
-    end if
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_smoother_descr
-
-  !
-  ! Dump 
-  ! to file, for debugging purposes.
-  !
-  subroutine z_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_z_base_smoother_type), intent(in) :: sm
-    integer, intent(in)              :: ictxt,level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: smoother, solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: smoother_
-    !  len of prefix_ 
-
-    info = 0
-
-    if (present(prefix)) then 
-      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-    else
-      prefix_ = "dump_smth_d"
-    end if
-
-    call psb_info(ictxt,iam,np)
-
-    if (present(smoother)) then 
-      smoother_ = smoother
-    else
-      smoother_ = .false. 
-    end if
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    ! At base level do nothing for the smoother
-    if (allocated(sm%sv)) &
-         & call sm%sv%dump(ictxt,level,info,solver=solver)
-
-  end subroutine z_base_smoother_dmp
-
   !
   ! Set sensible defaults.
   ! To be called immediately after allocation
@@ -610,5 +289,4 @@ contains
   end subroutine z_base_smoother_default
 
 
-
 end module mld_z_base_smoother_mod

mlprec/mld_z_base_solver_impl.f90

@@ -0,0 +1,338 @@
+!
+! Apply: comes in two versions, on plain arrays or on encapsulated
+! vectors.
+! The base version throws an error, since it means that no explicit
+! choice was made. 
+! Question: would it make sense to transform the base version into
+! the ID version, i.e. "base_solver" is the identity operator? 
+! 
+
+subroutine mld_z_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_apply
+  implicit none 
+  type(psb_desc_type), intent(in)           :: desc_data
+  class(mld_z_base_solver_type), intent(in) :: sv
+  complex(psb_dpk_),intent(inout)              :: x(:)
+  complex(psb_dpk_),intent(inout)              :: y(:)
+  complex(psb_dpk_),intent(in)                 :: alpha,beta
+  character(len=1),intent(in)               :: trans
+  complex(psb_dpk_),target, intent(inout)      :: work(:)
+  integer, intent(out)                      :: info
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_z_base_solver_apply
+
+subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_apply_vect
+  implicit none 
+  type(psb_desc_type), intent(in)              :: desc_data
+  class(mld_z_base_solver_type), intent(inout) :: sv
+  type(psb_z_vect_type),intent(inout)          :: x
+  type(psb_z_vect_type),intent(inout)          :: y
+  complex(psb_dpk_),intent(in)                    :: alpha,beta
+  character(len=1),intent(in)                  :: trans
+  complex(psb_dpk_),target, intent(inout)         :: work(:)
+  integer, intent(out)                         :: info
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_apply'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+
+end subroutine mld_z_base_solver_apply_vect
+
+
+!
+! Build
+! The base version throws an error, since it means that no explicit
+! choice was made. 
+!
+subroutine mld_z_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_bld
+  Implicit None
+  ! Arguments
+  type(psb_zspmat_type), intent(in), target           :: a
+  Type(psb_desc_type), Intent(in)                     :: desc_a 
+  class(mld_z_base_solver_type), intent(inout)        :: sv
+  character, intent(in)                               :: upd
+  integer, intent(out)                                :: info
+  type(psb_zspmat_type), intent(in), target, optional :: b
+  class(psb_z_base_sparse_mat), intent(in), optional  :: amold
+  class(psb_z_base_vect_type), intent(in), optional   :: vmold
+
+  Integer :: err_act
+  character(len=20)  :: name='d_base_solver_bld'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_solver_bld
+
+subroutine mld_z_base_solver_check(sv,info)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_check
+  Implicit None
+  ! Arguments
+  class(mld_z_base_solver_type), intent(inout) :: sv
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_solver_check
+
+!
+! Set.
+! The base version does nothing; the principle is that
+! SET acts on what is known, and delegates what is unknown.
+! Since we are at the bottom of the hierarchy, there's no one
+! to delegate, so we do nothing. 
+!
+subroutine mld_z_base_solver_seti(sv,what,val,info)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_seti
+  Implicit None
+  ! Arguments
+  class(mld_z_base_solver_type), intent(inout) :: sv 
+  integer, intent(in)                          :: what 
+  integer, intent(in)                          :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_seti'
+
+  ! Correct action here is doing nothing. 
+  info = 0
+
+  return
+end subroutine mld_z_base_solver_seti
+
+subroutine mld_z_base_solver_setc(sv,what,val,info)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_setc
+  Implicit None
+  ! Arguments
+  class(mld_z_base_solver_type), intent(inout) :: sv
+  integer, intent(in)                          :: what 
+  character(len=*), intent(in)                 :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act, ival 
+  character(len=20) :: name='d_base_solver_setc'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  call mld_stringval(val,ival,info)
+  if (info == psb_success_) call sv%set(what,ival,info)
+
+  if (info /= psb_success_) goto 9999
+
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_solver_setc
+
+subroutine mld_z_base_solver_setr(sv,what,val,info)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_setr
+  Implicit None
+  ! Arguments
+  class(mld_z_base_solver_type), intent(inout) :: sv 
+  integer, intent(in)                          :: what 
+  real(psb_dpk_), intent(in)                   :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_setr'
+
+
+  ! Correct action here is doing nothing. 
+  info = 0
+
+  return
+end subroutine mld_z_base_solver_setr
+
+!
+! Free
+! The base version throws an error, since it means that no explicit
+! choice was made. IS THIS CORRECT? I suspect it would be better
+! to be silent here, to cover reallocation. 
+!
+subroutine mld_z_base_solver_free(sv,info)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_free
+  Implicit None
+  ! Arguments
+  class(mld_z_base_solver_type), intent(inout) :: sv
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='d_base_solver_free'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_solver_free
+
+subroutine mld_z_base_solver_descr(sv,info,iout,coarse)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_descr
+  Implicit None
+  ! Arguments
+  class(mld_z_base_solver_type), intent(in) :: sv
+  integer, intent(out)                      :: info
+  integer, intent(in), optional             :: iout
+  logical, intent(in), optional             :: coarse
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_z_base_solver_descr'
+  integer      :: iout_
+
+
+  call psb_erractionsave(err_act)
+
+  info = psb_err_missing_override_method_
+  call psb_errpush(info,name)
+  goto 9999 
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_solver_descr
+
+!
+! Dump. For debugging purposes. 
+!
+subroutine mld_z_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
+  use psb_base_mod
+  use mld_z_base_solver_mod, mld_protect_name =>  mld_z_base_solver_dmp
+  implicit none 
+  class(mld_z_base_solver_type), intent(in) :: sv
+  integer, intent(in)              :: ictxt,level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: solver_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_slv_z"
+  end if
+
+  call psb_info(ictxt,iam,np)
+
+  if (present(solver)) then 
+    solver_ = solver
+  else
+    solver_ = .false. 
+  end if
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  ! At base level do nothing for the solver
+
+end subroutine mld_z_base_solver_dmp
+

mlprec/mld_z_base_solver_mod.f90

@@ -54,7 +54,8 @@
 module mld_z_base_solver_mod
 
   use mld_base_prec_type
-  use psb_base_mod, only : psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type
+  use psb_base_mod, only : psb_desc_type, psb_zspmat_type, psb_long_int_k_, &
+       & psb_z_vect_type, psb_z_base_vect_type, psb_z_base_sparse_mat, psb_dpk_
   !
   ! 
   ! Type: mld_T_base_solver_type.
@@ -83,32 +84,179 @@ module mld_z_base_solver_mod
 
   type mld_z_base_solver_type
   contains
-    procedure, pass(sv) :: check => z_base_solver_check
+    procedure, pass(sv) :: check => mld_z_base_solver_check
-    procedure, pass(sv) :: dump  => z_base_solver_dmp
+    procedure, pass(sv) :: dump  => mld_z_base_solver_dmp
-    procedure, pass(sv) :: build => z_base_solver_bld
+    procedure, pass(sv) :: build => mld_z_base_solver_bld
-    procedure, pass(sv) :: apply_v => z_base_solver_apply_vect
+    procedure, pass(sv) :: apply_v => mld_z_base_solver_apply_vect
-    procedure, pass(sv) :: apply_a => z_base_solver_apply
+    procedure, pass(sv) :: apply_a => mld_z_base_solver_apply
     generic, public     :: apply => apply_a, apply_v
-    procedure, pass(sv) :: free  => z_base_solver_free
+    procedure, pass(sv) :: free  => mld_z_base_solver_free
-    procedure, pass(sv) :: seti  => z_base_solver_seti
+    procedure, pass(sv) :: seti  => mld_z_base_solver_seti
-    procedure, pass(sv) :: setc  => z_base_solver_setc
+    procedure, pass(sv) :: setc  => mld_z_base_solver_setc
-    procedure, pass(sv) :: setr  => z_base_solver_setr
+    procedure, pass(sv) :: setr  => mld_z_base_solver_setr
     generic, public     :: set   => seti, setc, setr
     procedure, pass(sv) :: default => z_base_solver_default
-    procedure, pass(sv) :: descr   => z_base_solver_descr
+    procedure, pass(sv) :: descr   => mld_z_base_solver_descr
     procedure, pass(sv) :: sizeof  => z_base_solver_sizeof
     procedure, pass(sv) :: get_nzeros => z_base_solver_get_nzeros
   end type mld_z_base_solver_type
 
-  private :: z_base_solver_bld,  z_base_solver_apply, &
+  private :: z_base_solver_sizeof, z_base_solver_default,&
-       &  z_base_solver_free,    z_base_solver_seti, &
-       &  z_base_solver_setc,    z_base_solver_setr, &
-       &  z_base_solver_descr,   z_base_solver_sizeof, &
-       &  z_base_solver_default, z_base_solver_check,&
-       &  z_base_solver_dmp, z_base_solver_apply_vect, &
        &  z_base_solver_get_nzeros
 
 
+  interface  mld_z_base_solver_apply
+    subroutine mld_z_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+       & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+      type(psb_desc_type), intent(in)           :: desc_data
+      class(mld_z_base_solver_type), intent(in) :: sv
+      complex(psb_dpk_),intent(inout)              :: x(:)
+      complex(psb_dpk_),intent(inout)              :: y(:)
+      complex(psb_dpk_),intent(in)                 :: alpha,beta
+      character(len=1),intent(in)               :: trans
+      complex(psb_dpk_),target, intent(inout)      :: work(:)
+      integer, intent(out)                      :: info
+    end subroutine mld_z_base_solver_apply
+  end interface mld_z_base_solver_apply
+  
+      
+  interface mld_z_base_solver_apply_vect
+    subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+      
+      type(psb_desc_type), intent(in)              :: desc_data
+      class(mld_z_base_solver_type), intent(inout) :: sv
+      type(psb_z_vect_type),intent(inout)          :: x
+      type(psb_z_vect_type),intent(inout)          :: y
+      complex(psb_dpk_),intent(in)                    :: alpha,beta
+      character(len=1),intent(in)                  :: trans
+      complex(psb_dpk_),target, intent(inout)         :: work(:)
+      integer, intent(out)                         :: info
+    end subroutine mld_z_base_solver_apply_vect
+  end interface mld_z_base_solver_apply_vect
+  
+  interface mld_z_base_solver_bld
+    subroutine mld_z_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+       & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      type(psb_zspmat_type), intent(in), target           :: a
+      Type(psb_desc_type), Intent(in)                     :: desc_a 
+      class(mld_z_base_solver_type), intent(inout)        :: sv
+      character, intent(in)                               :: upd
+      integer, intent(out)                                :: info
+      type(psb_zspmat_type), intent(in), target, optional :: b
+      class(psb_z_base_sparse_mat), intent(in), optional  :: amold
+      class(psb_z_base_vect_type), intent(in), optional   :: vmold
+    end subroutine mld_z_base_solver_bld
+  end interface mld_z_base_solver_bld
+  
+  interface mld_z_base_solver_check
+    subroutine mld_z_base_solver_check(sv,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+
+      Implicit None
+      
+      ! Arguments
+      class(mld_z_base_solver_type), intent(inout) :: sv
+      integer, intent(out)                   :: info
+    end subroutine mld_z_base_solver_check
+  end interface mld_z_base_solver_check
+  
+  interface mld_z_base_solver_seti
+    subroutine mld_z_base_solver_seti(sv,what,val,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      class(mld_z_base_solver_type), intent(inout) :: sv 
+      integer, intent(in)                          :: what 
+      integer, intent(in)                          :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_z_base_solver_seti
+  end interface mld_z_base_solver_seti
+  
+  interface  mld_z_base_solver_setc
+    subroutine mld_z_base_solver_setc(sv,what,val,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_z_base_solver_type), intent(inout) :: sv
+      integer, intent(in)                          :: what 
+      character(len=*), intent(in)                 :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_z_base_solver_setc
+  end interface mld_z_base_solver_setc
+  
+  interface  mld_z_base_solver_setr
+    subroutine mld_z_base_solver_setr(sv,what,val,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+            
+      Implicit None
+      
+      ! Arguments
+      class(mld_z_base_solver_type), intent(inout) :: sv 
+      integer, intent(in)                          :: what 
+      real(psb_dpk_), intent(in)                   :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_z_base_solver_setr
+  end interface mld_z_base_solver_setr
+  
+  interface  mld_z_base_solver_free
+    subroutine mld_z_base_solver_free(sv,info)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_z_base_solver_type), intent(inout) :: sv
+      integer, intent(out)                         :: info
+    end subroutine mld_z_base_solver_free
+  end interface mld_z_base_solver_free
+  
+  interface  mld_z_base_solver_descr
+    subroutine mld_z_base_solver_descr(sv,info,iout,coarse)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+      
+      Implicit None
+      
+      ! Arguments
+      class(mld_z_base_solver_type), intent(in) :: sv
+      integer, intent(out)                      :: info
+      integer, intent(in), optional             :: iout
+      logical, intent(in), optional             :: coarse
+
+    end subroutine mld_z_base_solver_descr
+  end interface mld_z_base_solver_descr
+  
+  interface  mld_z_base_solver_dmp
+    subroutine mld_z_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
+      import :: psb_desc_type, psb_zspmat_type,  psb_z_base_sparse_mat, &
+           & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, mld_z_base_solver_type
+      
+      implicit none 
+      class(mld_z_base_solver_type), intent(in) :: sv
+      integer, intent(in)              :: ictxt,level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: solver
+    end subroutine mld_z_base_solver_dmp
+  end interface mld_z_base_solver_dmp
+  
+
+
 
 contains
   !
@@ -135,354 +283,6 @@ contains
     val = 0
   end function z_base_solver_get_nzeros
 
-  
-  !
-  ! Apply: comes in two versions, on plain arrays or on encapsulated
-  ! vectors.
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. 
-  ! Question: would it make sense to transform the base version into
-  ! the ID version, i.e. "base_solver" is the identity operator? 
-  ! 
-
-  subroutine z_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)           :: desc_data
-    class(mld_z_base_solver_type), intent(in) :: sv
-    complex(psb_dpk_),intent(inout)              :: x(:)
-    complex(psb_dpk_),intent(inout)              :: y(:)
-    complex(psb_dpk_),intent(in)                 :: alpha,beta
-    character(len=1),intent(in)               :: trans
-    complex(psb_dpk_),target, intent(inout)      :: work(:)
-    integer, intent(out)                      :: info
-    
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_apply'
-
-    call psb_erractionsave(err_act)
-    
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine z_base_solver_apply
-
-  subroutine z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info)
-    use psb_base_mod
-    type(psb_desc_type), intent(in)              :: desc_data
-    class(mld_z_base_solver_type), intent(inout) :: sv
-    type(psb_z_vect_type),intent(inout)          :: x
-    type(psb_z_vect_type),intent(inout)          :: y
-    complex(psb_dpk_),intent(in)                    :: alpha,beta
-    character(len=1),intent(in)                  :: trans
-    complex(psb_dpk_),target, intent(inout)         :: work(:)
-    integer, intent(out)                         :: info
-    
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_apply'
-
-    call psb_erractionsave(err_act)
-    
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-    
-  end subroutine z_base_solver_apply_vect
-
-
-  !
-  ! Build
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. 
-  !
-  subroutine z_base_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    type(psb_zspmat_type), intent(in), target           :: a
-    Type(psb_desc_type), Intent(in)                     :: desc_a 
-    class(mld_z_base_solver_type), intent(inout)        :: sv
-    character, intent(in)                               :: upd
-    integer, intent(out)                                :: info
-    type(psb_zspmat_type), intent(in), target, optional :: b
-    class(psb_z_base_sparse_mat), intent(in), optional  :: amold
-    class(psb_z_base_vect_type), intent(in), optional   :: vmold
-
-    Integer :: err_act
-    character(len=20)  :: name='d_base_solver_bld'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_solver_bld
-
-  subroutine z_base_solver_check(sv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_solver_type), intent(inout) :: sv
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_solver_check
-
-  !
-  ! Set.
-  ! The base version does nothing; the principle is that
-  ! SET acts on what is known, and delegates what is unknown.
-  ! Since we are at the bottom of the hierarchy, there's no one
-  ! to delegate, so we do nothing. 
-  !
-  subroutine z_base_solver_seti(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_solver_type), intent(inout) :: sv 
-    integer, intent(in)                          :: what 
-    integer, intent(in)                          :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_seti'
-    
-    ! Correct action here is doing nothing. 
-    info = 0
-    
-    return
-  end subroutine z_base_solver_seti
-
-  subroutine z_base_solver_setc(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_solver_type), intent(inout) :: sv
-    integer, intent(in)                          :: what 
-    character(len=*), intent(in)                 :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act, ival 
-    character(len=20) :: name='d_base_solver_setc'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    call mld_stringval(val,ival,info)
-    if (info == psb_success_) call sv%set(what,ival,info)
-
-    if (info /= psb_success_) goto 9999
-
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_solver_setc
-  
-  subroutine z_base_solver_setr(sv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_solver_type), intent(inout) :: sv 
-    integer, intent(in)                          :: what 
-    real(psb_dpk_), intent(in)                   :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_setr'
-
-    
-    ! Correct action here is doing nothing. 
-    info = 0
-    
-    return
-  end subroutine z_base_solver_setr
-
-  !
-  ! Free
-  ! The base version throws an error, since it means that no explicit
-  ! choice was made. IS THIS CORRECT? I suspect it would be better
-  ! to be silent here, to cover reallocation. 
-  !
-  subroutine z_base_solver_free(sv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_solver_type), intent(inout) :: sv
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_solver_free'
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_solver_free
-
-  subroutine z_base_solver_descr(sv,info,iout,coarse)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_z_base_solver_type), intent(in) :: sv
-    integer, intent(out)                      :: info
-    integer, intent(in), optional             :: iout
-    logical, intent(in), optional             :: coarse
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_z_base_solver_descr'
-    integer      :: iout_
-
-
-    call psb_erractionsave(err_act)
-
-    info = psb_err_missing_override_method_
-    call psb_errpush(info,name)
-    goto 9999 
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_solver_descr
-
-  !
-  ! Dump. For debugging purposes. 
-  !
-  subroutine z_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_z_base_solver_type), intent(in) :: sv
-    integer, intent(in)              :: ictxt,level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: solver_
-    !  len of prefix_ 
-
-    info = 0
-
-    if (present(prefix)) then 
-      prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
-    else
-      prefix_ = "dump_slv_d"
-    end if
-
-    call psb_info(ictxt,iam,np)
-
-    if (present(solver)) then 
-      solver_ = solver
-    else
-      solver_ = .false. 
-    end if
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    ! At base level do nothing for the solver
-
-  end subroutine z_base_solver_dmp
-
   subroutine z_base_solver_default(sv) 
     implicit none 
     ! Arguments
@@ -492,6 +292,4 @@ contains
     return
   end subroutine z_base_solver_default
 
-
-
 end module mld_z_base_solver_mod

mlprec/mld_z_onelev_impl.f90

@@ -0,0 +1,459 @@
+!!$
+!!$ 
+!!$                           MLD2P4  version 2.0
+!!$  MultiLevel Domain Decomposition Parallel Preconditioners Package
+!!$             based on PSBLAS (Parallel Sparse BLAS version 3.0)
+!!$  
+!!$  (C) Copyright 2008,2009,2010
+!!$
+!!$                      Salvatore Filippone  University of Rome Tor Vergata
+!!$                      Alfredo Buttari      CNRS-IRIT, Toulouse
+!!$                      Pasqua D'Ambra       ICAR-CNR, Naples
+!!$                      Daniela di Serafino  Second University of Naples
+!!$ 
+!!$  Redistribution and use in source and binary forms, with or without
+!!$  modification, are permitted provided that the following conditions
+!!$  are met:
+!!$    1. Redistributions of source code must retain the above copyright
+!!$       notice, this list of conditions and the following disclaimer.
+!!$    2. Redistributions in binary form must reproduce the above copyright
+!!$       notice, this list of conditions, and the following disclaimer in the
+!!$       documentation and/or other materials provided with the distribution.
+!!$    3. The name of the MLD2P4 group or the names of its contributors may
+!!$       not be used to endorse or promote products derived from this
+!!$       software without specific written permission.
+!!$ 
+!!$  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!!$  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+!!$  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+!!$  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
+!!$  BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+!!$  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+!!$  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+!!$  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+!!$  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+!!$  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+!!$  POSSIBILITY OF SUCH DAMAGE.
+!!$ 
+!!$
+
+!
+! Subroutine: mld_file_onelev_descr
+! Version: complex
+!
+!  This routine prints a description of the preconditioner to the standard 
+!  output or to a file. It must be called after the preconditioner has been
+!  built by mld_precbld.
+!
+! Arguments:
+!  p       -  type(mld_Tprec_type), input.
+!             The preconditioner data structure to be printed out.
+!  info    -  integer, output.
+!             error code.
+!  iout    -  integer, input, optional.
+!             The id of the file where the preconditioner description
+!             will be printed. If iout is not present, then the standard
+!             output is condidered.
+!
+subroutine mld_z_base_onelev_descr(lv,il,nl,info,iout)
+  use psb_base_mod
+  use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_descr
+  Implicit None
+  ! Arguments
+  class(mld_zonelev_type), intent(in) :: lv
+  integer, intent(in)                 :: il,nl
+  integer, intent(out)                :: info
+  integer, intent(in), optional       :: iout
+
+  ! Local variables
+  integer      :: err_act
+  integer      :: ictxt, me, np
+  character(len=20), parameter :: name='mld_z_base_onelev_descr'
+  integer      :: iout_
+  logical      :: coarse
+
+
+  call psb_erractionsave(err_act)
+
+
+  coarse = (il==nl)
+
+  if (present(iout)) then 
+    iout_ = iout
+  else 
+    iout_ = 6
+  end if
+
+  write(iout_,*) 
+  if (il == 2) then 
+    call lv%parms%mldescr(iout_,info)
+    write(iout_,*) 
+  end if
+
+  if (coarse)  then 
+    write(iout_,*) ' Level ',il,' (coarsest)'
+  else
+    write(iout_,*) ' Level ',il
+  end if
+
+  call lv%parms%descr(iout_,info,coarse=coarse)
+
+  if (nl > 1) then 
+    if (allocated(lv%map%naggr)) then
+      write(iout_,*) '  Size of coarse matrix: ', &
+           &  sum(lv%map%naggr(:))
+      write(iout_,*) '  Sizes of aggregates: ', &
+           &  lv%map%naggr(:)
+    end if
+  end if
+
+  if (coarse.and.allocated(lv%sm)) &
+       & call lv%sm%descr(info,iout=iout_,coarse=coarse)
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_onelev_descr
+
+
+!
+! Subroutines: mld_T_onelev_precfree
+! Version: complex
+!
+!  These routines deallocate the mld_Tonelev_type 
+!
+! Arguments:
+!  p       -  type(mld_Tonelev_type), input.
+!             The data structure to be deallocated.
+!  info    -  integer, output.
+!             error code.
+!
+subroutine mld_z_base_onelev_free(lv,info)
+  use psb_base_mod
+  use mld_zonelev_mod, mld_protect_name =>:  mld_T_onelev_precfree
+  implicit none 
+
+  class(mld_zonelev_type), intent(inout) :: lv
+  integer, intent(out)                :: info
+  integer :: i
+
+  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. 
+  call lv%sm%free(info)
+
+  call lv%ac%free()
+  if (psb_is_ok_desc(lv%desc_ac)) &
+       & call psb_cdfree(lv%desc_ac,info)
+  call lv%map%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) 
+
+  call lv%nullify()
+
+end subroutine mld_z_base_onelev_free
+
+!
+! Onelevel checks. 
+! The number of Jacobi sweeps to be applied is not
+! tied to the Jacobi smoother: logically, you have
+! a smoother and you can choose to apply it any number
+! of times you like. 
+!
+subroutine mld_z_base_onelev_check(lv,info)
+  use psb_base_mod
+  use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_check
+
+  Implicit None
+
+  ! Arguments
+  class(mld_zonelev_type), intent(inout) :: lv 
+  integer, intent(out)                   :: info
+  Integer           :: err_act
+  character(len=20) :: name='z_base_onelev_check'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  call mld_check_def(lv%parms%sweeps,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+  call mld_check_def(lv%parms%sweeps_pre,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+  call mld_check_def(lv%parms%sweeps_post,&
+       & 'Jacobi sweeps',1,is_legal_jac_sweeps)
+
+
+  if (allocated(lv%sm)) then 
+    call lv%sm%check(info)
+  else 
+    info=3111
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_onelev_check
+
+
+! 
+! Set routines:
+! Parameters belonging here are:
+!   Number of smoothing sweeps;
+!   Smoother position;
+!   Aggregation related parameters
+!   Record request on coarse level solver,
+!    for checks on solver vs. smoother nomenclature
+!    reconciliation. 
+! 
+subroutine mld_z_base_onelev_seti(lv,what,val,info)
+  use psb_base_mod
+  use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_seti
+
+  Implicit None
+
+  ! Arguments
+  class(mld_zonelev_type), intent(inout) :: lv 
+  integer, intent(in)                          :: what 
+  integer, intent(in)                          :: val
+  integer, intent(out)                         :: info
+  Integer           :: err_act
+  character(len=20) :: name='z_base_onelev_seti'
+
+  call psb_erractionsave(err_act)
+  info = psb_success_
+
+  select case (what) 
+
+  case (mld_smoother_sweeps_)
+    lv%parms%sweeps      = val
+    lv%parms%sweeps_pre  = val
+    lv%parms%sweeps_post = val
+
+  case (mld_smoother_sweeps_pre_)
+    lv%parms%sweeps_pre  = val
+
+  case (mld_smoother_sweeps_post_)
+    lv%parms%sweeps_post = val
+
+  case (mld_ml_type_)
+    lv%parms%ml_type       = val
+
+  case (mld_aggr_alg_)
+    lv%parms%aggr_alg      = val
+
+  case (mld_aggr_kind_)
+    lv%parms%aggr_kind     = val
+
+  case (mld_coarse_mat_)
+    lv%parms%coarse_mat    = val
+
+  case (mld_smoother_pos_)
+    lv%parms%smoother_pos  = val
+
+  case (mld_aggr_omega_alg_)
+    lv%parms%aggr_omega_alg= val
+
+  case (mld_aggr_eig_)
+    lv%parms%aggr_eig      = val
+
+  case (mld_aggr_filter_)
+    lv%parms%aggr_filter   = val
+
+  case (mld_coarse_solve_)
+    lv%parms%coarse_solve    = val
+
+  case default
+    if (allocated(lv%sm)) then 
+      call lv%sm%set(what,val,info)
+    end if
+    if (info /= psb_success_) goto 9999
+  end select
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_onelev_seti
+
+subroutine mld_z_base_onelev_setc(lv,what,val,info)
+  use psb_base_mod
+  use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_setc
+
+  Implicit None
+
+  ! Arguments
+  class(mld_zonelev_type), intent(inout) :: lv 
+  integer, intent(in)                            :: what 
+  character(len=*), intent(in)                   :: val
+  integer, intent(out)                           :: info
+  Integer           :: err_act
+  character(len=20) :: name='z_base_onelev_setc'
+  integer :: ival 
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+
+  call mld_stringval(val,ival,info)
+  if (info == psb_success_) call lv%set(what,ival,info)
+
+  if (info /= psb_success_) goto 9999
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_onelev_setc
+
+subroutine mld_z_base_onelev_setr(lv,what,val,info)
+  use psb_base_mod
+  use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_setr
+
+  Implicit None
+
+  ! Arguments
+  class(mld_zonelev_type), intent(inout) :: lv 
+  integer, intent(in)                            :: what 
+  real(psb_dpk_), intent(in)                     :: val
+  integer, intent(out)                           :: info
+  Integer :: err_act
+  character(len=20)  :: name='z_base_onelev_setr'
+
+  call psb_erractionsave(err_act)
+
+
+  info = psb_success_
+
+  select case (what) 
+
+  case (mld_aggr_omega_val_)
+    lv%parms%aggr_omega_val= val
+
+  case (mld_aggr_thresh_)
+    lv%parms%aggr_thresh   = val
+
+  case default
+    if (allocated(lv%sm)) then 
+      call lv%sm%set(what,val,info)
+    end if
+    if (info /= psb_success_) goto 9999
+  end select
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 continue
+  call psb_erractionrestore(err_act)
+  if (err_act == psb_act_abort_) then
+    call psb_error()
+    return
+  end if
+  return
+end subroutine mld_z_base_onelev_setr
+
+!
+! Dump on file: can be fine-tuned to include the (aggregated) matrix
+! as well as smoother and solver. 
+!
+subroutine mld_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
+  use psb_base_mod
+  use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_dump
+  implicit none 
+  class(mld_zonelev_type), intent(in) :: lv
+  integer, intent(in)              :: level
+  integer, intent(out)             :: info
+  character(len=*), intent(in), optional :: prefix, head
+  logical, optional, intent(in)    :: ac, rp, smoother, solver
+  integer :: i, j, il1, iln, lname, lev
+  integer :: icontxt,iam, np
+  character(len=80)  :: prefix_
+  character(len=120) :: fname ! len should be at least 20 more than
+  logical :: ac_, rp_
+  !  len of prefix_ 
+
+  info = 0
+
+  if (present(prefix)) then 
+    prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
+  else
+    prefix_ = "dump_lev_z"
+  end if
+
+  if (associated(lv%base_desc)) then 
+    icontxt = lv%base_desc%get_context()
+    call psb_info(icontxt,iam,np)
+  else 
+    icontxt = -1 
+    iam     = -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
+  lname = len_trim(prefix_)
+  fname = trim(prefix_)
+  write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
+  lname = lname + 5
+
+  if (level >= 2) then 
+    if (ac_) then 
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%ac%print(fname,head=head)
+    end if
+    if (rp_) then 
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%map%map_X2Y%print(fname,head=head)
+      write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
+      write(0,*) 'Filename ',fname
+      call lv%map%map_Y2X%print(fname,head=head)
+    end if
+  end if
+  if (allocated(lv%sm)) &
+       & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver)
+
+end subroutine mld_z_base_onelev_dump
+
+

mlprec/mld_z_onelev_mod.f90

@@ -57,7 +57,7 @@ module mld_z_onelev_mod
   use mld_base_prec_type
   use mld_z_base_smoother_mod
   use psb_base_mod, only : psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
-       & psb_zlinmap_type
+       & psb_zlinmap_type, psb_dpk_, psb_long_int_k_, psb_desc_type
   !
   !
   ! Type: mld_Tonelev_type.
@@ -127,31 +127,112 @@ module mld_z_onelev_mod
     type(psb_desc_type), pointer    :: base_desc => null() 
     type(psb_zlinmap_type)          :: map
   contains
-    procedure, pass(lv) :: descr   => z_base_onelev_descr
+    procedure, pass(lv) :: descr   => mld_z_base_onelev_descr
     procedure, pass(lv) :: default => z_base_onelev_default
-    procedure, pass(lv) :: free    => z_base_onelev_free
+    procedure, pass(lv) :: free    => mld_z_base_onelev_free
     procedure, pass(lv) :: nullify => z_base_onelev_nullify
-    procedure, pass(lv) :: check => z_base_onelev_check
+    procedure, pass(lv) :: check => mld_z_base_onelev_check
-    procedure, pass(lv) :: dump  => z_base_onelev_dump
+    procedure, pass(lv) :: dump  => mld_z_base_onelev_dump
-    procedure, pass(lv) :: seti  => z_base_onelev_seti
+    procedure, pass(lv) :: seti  => mld_z_base_onelev_seti
-    procedure, pass(lv) :: setr  => z_base_onelev_setr
+    procedure, pass(lv) :: setr  => mld_z_base_onelev_setr
-    procedure, pass(lv) :: setc  => z_base_onelev_setc
+    procedure, pass(lv) :: setc  => mld_z_base_onelev_setc
     generic, public     :: set   => seti, setr, setc
     procedure, pass(lv) :: sizeof => z_base_onelev_sizeof
     procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros
   end type mld_zonelev_type
 
-  private :: z_base_onelev_seti, z_base_onelev_setc, &
+  private :: z_base_onelev_default, z_base_onelev_sizeof, &
-       &  z_base_onelev_setr, z_base_onelev_check, &
+       &  z_base_onelev_nullify, z_base_onelev_get_nzeros
-       &  z_base_onelev_default, z_base_onelev_dump, &
+
-       &  z_base_onelev_descr,  z_base_onelev_sizeof, &
+
-       &  z_base_onelev_free,  z_base_onelev_nullify,&
+
-       &  z_base_onelev_get_nzeros
+  interface mld_z_base_onelev_descr
-
+    subroutine mld_z_base_onelev_descr(lv,il,nl,info,iout)
-
+      import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
-  interface mld_nullify_onelevprec
+           & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type
-    module procedure  mld_nullify_d_onelevprec
+      Implicit None
-  end interface
+      ! Arguments
+      class(mld_zonelev_type), intent(in) :: lv
+      integer, intent(in)                 :: il,nl
+      integer, intent(out)                :: info
+      integer, intent(in), optional       :: iout
+    end subroutine mld_z_base_onelev_descr
+  end interface mld_z_base_onelev_descr
+  
+  interface mld_z_base_onelev_free
+    subroutine mld_z_base_onelev_free(lv,info)
+      import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
+           & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type
+      implicit none 
+      
+      class(mld_zonelev_type), intent(inout) :: lv
+      integer, intent(out)                :: info
+    end subroutine mld_z_base_onelev_free
+  end interface mld_z_base_onelev_free
+  
+  interface mld_z_base_onelev_check
+    subroutine mld_z_base_onelev_check(lv,info)
+      import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
+           & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      ! Arguments
+      class(mld_zonelev_type), intent(inout) :: lv 
+      integer, intent(out)                   :: info
+    end subroutine mld_z_base_onelev_check
+  end interface mld_z_base_onelev_check
+  
+  interface mld_z_base_onelev_seti
+    subroutine mld_z_base_onelev_seti(lv,what,val,info)
+      import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
+           & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      
+      ! Arguments
+      class(mld_zonelev_type), intent(inout) :: lv 
+      integer, intent(in)                          :: what 
+      integer, intent(in)                          :: val
+      integer, intent(out)                         :: info
+    end subroutine mld_z_base_onelev_seti
+  end interface mld_z_base_onelev_seti
+  
+  interface mld_z_base_onelev_setc
+    subroutine mld_z_base_onelev_setc(lv,what,val,info)
+      import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
+           & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      ! Arguments
+      class(mld_zonelev_type), intent(inout) :: lv 
+      integer, intent(in)                            :: what 
+      character(len=*), intent(in)                   :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_z_base_onelev_setc
+  end interface mld_z_base_onelev_setc
+  
+  interface mld_z_base_onelev_setr
+    subroutine mld_z_base_onelev_setr(lv,what,val,info)
+      import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
+           & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type
+      Implicit None
+      
+      class(mld_zonelev_type), intent(inout) :: lv 
+      integer, intent(in)                            :: what 
+      real(psb_dpk_), intent(in)                     :: val
+      integer, intent(out)                           :: info
+    end subroutine mld_z_base_onelev_setr
+  end interface mld_z_base_onelev_setr
+
+  interface mld_z_base_onelev_dump
+    subroutine mld_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
+      import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
+           & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type
+      implicit none 
+      class(mld_zonelev_type), intent(in) :: lv
+      integer, intent(in)              :: level
+      integer, intent(out)             :: info
+      character(len=*), intent(in), optional :: prefix, head
+      logical, optional, intent(in)    :: ac, rp, smoother, solver
+    end subroutine mld_z_base_onelev_dump
+  end interface mld_z_base_onelev_dump
   
   
 contains
@@ -184,137 +265,6 @@ contains
   end function z_base_onelev_sizeof
 
 
-  !
-  ! Subroutine: mld_file_onelev_descr
-  ! Version: complex
-  !
-  !  This routine prints a description of the preconditioner to the standard 
-  !  output or to a file. It must be called after the preconditioner has been
-  !  built by mld_precbld.
-  !
-  ! Arguments:
-  !  p       -  type(mld_Tprec_type), input.
-  !             The preconditioner data structure to be printed out.
-  !  info    -  integer, output.
-  !             error code.
-  !  iout    -  integer, input, optional.
-  !             The id of the file where the preconditioner description
-  !             will be printed. If iout is not present, then the standard
-  !             output is condidered.
-  !
-  subroutine z_base_onelev_descr(lv,il,nl,info,iout)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_zonelev_type), intent(in) :: lv
-    integer, intent(in)                 :: il,nl
-    integer, intent(out)                :: info
-    integer, intent(in), optional       :: iout
-
-    ! Local variables
-    integer      :: err_act
-    integer      :: ictxt, me, np
-    character(len=20), parameter :: name='mld_z_base_onelev_descr'
-    integer      :: iout_
-    logical      :: coarse
-
-
-    call psb_erractionsave(err_act)
-
-
-    coarse = (il==nl)
-
-    if (present(iout)) then 
-      iout_ = iout
-    else 
-      iout_ = 6
-    end if
-    
-    write(iout_,*) 
-    if (il == 2) then 
-      call lv%parms%mldescr(iout_,info)
-      write(iout_,*) 
-    end if
-
-    if (coarse)  then 
-      write(iout_,*) ' Level ',il,' (coarsest)'
-    else
-      write(iout_,*) ' Level ',il
-    end if
-
-    call lv%parms%descr(iout_,info,coarse=coarse)
-        
-    if (nl > 1) then 
-      if (allocated(lv%map%naggr)) then
-        write(iout_,*) '  Size of coarse matrix: ', &
-             &  sum(lv%map%naggr(:))
-        write(iout_,*) '  Sizes of aggregates: ', &
-             &  lv%map%naggr(:)
-      end if
-    end if
-
-    if (coarse.and.allocated(lv%sm)) &
-         & call lv%sm%descr(info,iout=iout_,coarse=coarse)
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_onelev_descr
-
-
-  !
-  ! Subroutines: mld_T_onelev_precfree
-  ! Version: complex
-  !
-  !  These routines deallocate the mld_Tonelev_type 
-  !
-  ! Arguments:
-  !  p       -  type(mld_Tonelev_type), input.
-  !             The data structure to be deallocated.
-  !  info    -  integer, output.
-  !             error code.
-  !
-  subroutine z_base_onelev_free(lv,info)
-    use psb_base_mod
-    implicit none 
-
-    class(mld_zonelev_type), intent(inout) :: lv
-    integer, intent(out)                :: info
-    integer :: i
-
-    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. 
-    call lv%sm%free(info)
-    
-    call lv%ac%free()
-    if (psb_is_ok_desc(lv%desc_ac)) &
-         & call psb_cdfree(lv%desc_ac,info)
-    call lv%map%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) 
-
-    call lv%nullify()
-
-  end subroutine z_base_onelev_free
-
-
   subroutine z_base_onelev_nullify(lv)
     implicit none 
 
@@ -325,69 +275,6 @@ contains
 
   end subroutine z_base_onelev_nullify
 
-
-  subroutine mld_nullify_d_onelevprec(p)
-    implicit none 
-
-    type(mld_zonelev_type), intent(inout) :: p
-
-    nullify(p%base_a) 
-    nullify(p%base_desc) 
-
-  end subroutine mld_nullify_d_onelevprec
-
-  !
-  ! Onelevel checks. 
-  ! The number of Jacobi sweeps to be applied is not
-  ! tied to the Jacobi smoother: logically, you have
-  ! a smoother and you can choose to apply it any number
-  ! of times you like. 
-  !
-  subroutine z_base_onelev_check(lv,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_zonelev_type), intent(inout) :: lv 
-    integer, intent(out)                   :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_check'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    call mld_check_def(lv%parms%sweeps,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-    call mld_check_def(lv%parms%sweeps_pre,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-    call mld_check_def(lv%parms%sweeps_post,&
-         & 'Jacobi sweeps',1,is_legal_jac_sweeps)
-
-    
-    if (allocated(lv%sm)) then 
-      call lv%sm%check(info)
-    else 
-      info=3111
-      call psb_errpush(info,name)
-      goto 9999
-    end if
-
-    if (info /= psb_success_) goto 9999
-    
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_onelev_check
-
   !
   ! Multilevel defaults: 
   !  multiplicative vs. additive ML framework;
@@ -400,8 +287,6 @@ contains
 
   subroutine z_base_onelev_default(lv)
 
-    use psb_base_mod
-
     Implicit None
 
     ! Arguments
@@ -427,241 +312,4 @@ contains
 
   end subroutine z_base_onelev_default
 
-  ! 
-  ! Set routines:
-  ! Parameters belonging here are:
-  !   Number of smoothing sweeps;
-  !   Smoother position;
-  !   Aggregation related parameters
-  !   Record request on coarse level solver,
-  !    for checks on solver vs. smoother nomenclature
-  !    reconciliation. 
-  ! 
-  subroutine z_base_onelev_seti(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_zonelev_type), intent(inout) :: lv 
-    integer, intent(in)                          :: what 
-    integer, intent(in)                          :: val
-    integer, intent(out)                         :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_seti'
-
-    call psb_erractionsave(err_act)
-    info = psb_success_
-
-    select case (what) 
-
-    case (mld_smoother_sweeps_)
-      lv%parms%sweeps      = val
-      lv%parms%sweeps_pre  = val
-      lv%parms%sweeps_post = val
-
-    case (mld_smoother_sweeps_pre_)
-      lv%parms%sweeps_pre  = val
-
-    case (mld_smoother_sweeps_post_)
-      lv%parms%sweeps_post = val
-
-    case (mld_ml_type_)
-      lv%parms%ml_type       = val
-
-    case (mld_aggr_alg_)
-      lv%parms%aggr_alg      = val
-
-    case (mld_aggr_kind_)
-      lv%parms%aggr_kind     = val
-
-    case (mld_coarse_mat_)
-      lv%parms%coarse_mat    = val
-
-    case (mld_smoother_pos_)
-      lv%parms%smoother_pos  = val
-
-    case (mld_aggr_omega_alg_)
-      lv%parms%aggr_omega_alg= val
-
-    case (mld_aggr_eig_)
-      lv%parms%aggr_eig      = val
-
-    case (mld_aggr_filter_)
-      lv%parms%aggr_filter   = val
-
-    case (mld_coarse_solve_)
-      lv%parms%coarse_solve    = val
-
-    case default
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info)
-      end if
-      if (info /= psb_success_) goto 9999
-    end select
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_onelev_seti
-
-  subroutine z_base_onelev_setc(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_zonelev_type), intent(inout) :: lv 
-    integer, intent(in)                            :: what 
-    character(len=*), intent(in)                   :: val
-    integer, intent(out)                           :: info
-    Integer           :: err_act
-    character(len=20) :: name='d_base_onelev_setc'
-    integer :: ival 
-
-    call psb_erractionsave(err_act)
-
-    info = psb_success_
-
-    call mld_stringval(val,ival,info)
-    if (info == psb_success_) call lv%set(what,ival,info)
-
-    if (info /= psb_success_) goto 9999
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_onelev_setc
-  
-  subroutine z_base_onelev_setr(lv,what,val,info)
-
-    use psb_base_mod
-
-    Implicit None
-
-    ! Arguments
-    class(mld_zonelev_type), intent(inout) :: lv 
-    integer, intent(in)                            :: what 
-    real(psb_dpk_), intent(in)                     :: val
-    integer, intent(out)                           :: info
-    Integer :: err_act
-    character(len=20)  :: name='d_base_onelev_setr'
-
-    call psb_erractionsave(err_act)
-
-
-    info = psb_success_
-    
-    select case (what) 
-
-    case (mld_aggr_omega_val_)
-      lv%parms%aggr_omega_val= val
-   
-    case (mld_aggr_thresh_)
-      lv%parms%aggr_thresh   = val
-
-    case default
-      if (allocated(lv%sm)) then 
-        call lv%sm%set(what,val,info)
-      end if
-      if (info /= psb_success_) goto 9999
-    end select
-
-    call psb_erractionrestore(err_act)
-    return
-
-9999 continue
-    call psb_erractionrestore(err_act)
-    if (err_act == psb_act_abort_) then
-      call psb_error()
-      return
-    end if
-    return
-  end subroutine z_base_onelev_setr
-
-  !
-  ! Dump on file: can be fine-tuned to include the (aggregated) matrix
-  ! as well as smoother and solver. 
-  !
-  subroutine z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver)
-    use psb_base_mod
-    implicit none 
-    class(mld_zonelev_type), intent(in) :: lv
-    integer, intent(in)              :: level
-    integer, intent(out)             :: info
-    character(len=*), intent(in), optional :: prefix, head
-    logical, optional, intent(in)    :: ac, rp, smoother, solver
-    integer :: i, j, il1, iln, lname, lev
-    integer :: icontxt,iam, np
-    character(len=80)  :: prefix_
-    character(len=120) :: fname ! len should be at least 20 more than
-    logical :: ac_, rp_
-    !  len of prefix_ 
-
-    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 
-      icontxt = lv%base_desc%get_context()
-      call psb_info(icontxt,iam,np)
-    else 
-      icontxt = -1 
-      iam     = -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
-    lname = len_trim(prefix_)
-    fname = trim(prefix_)
-    write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
-    lname = lname + 5
-
-    if (level >= 2) then 
-      if (ac_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%ac%print(fname,head=head)
-      end if
-      if (rp_) then 
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%map%map_X2Y%print(fname,head=head)
-        write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
-        write(0,*) 'Filename ',fname
-        call lv%map%map_Y2X%print(fname,head=head)
-      end if
-    end if
-    if (allocated(lv%sm)) &
-         & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver)
-
-  end subroutine z_base_onelev_dump
-
-
 end module mld_z_onelev_mod