Merge branch 'unify_aggr_bld' into unify_aggr_bld_richardson to fix REPL instance

Originally it was introduced to handle cases where the stencil was
expanded by the smoothing and multiplication process, but the
critical step is handled in AGGR%BLD_MAP, this one can be discarded.

cbind/mlprec/mld_dprec_cbind_mod.F90

@@ -8,7 +8,7 @@ module mld_dprec_cbind_mod
     type(c_ptr) :: item = c_null_ptr
   end type mld_c_dprec
 
-contains 
+contains
 
 #if 1
 #define MLDC_DEBUG(MSG) write(*,*) __FILE__,':',__LINE__,':',MSG
@@ -21,13 +21,13 @@ contains
 !#define MLDC_ERR_FILTER(INFO) min(0,INFO)
 #define MLDC_ERR_FILTER(INFO) (INFO)
 #define MLDC_ERR_HANDLE(INFO) if(INFO/=mld_success_)MLDC_ERROR("ERROR!")
-    
+
   function  mld_c_dprecinit(ictxt,ph,ptype) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_)  :: res   
+    implicit none
+
+    integer(psb_c_ipk_)  :: res
     type(mld_c_dprec)    :: ph
     integer(psb_c_ipk_), value :: ictxt
     character(c_char)     :: ptype(*)
@@ -36,20 +36,20 @@ contains
     character(len=80)     :: fptype
 
     res = -1
-    res = -1
-    if (c_associated(ph%item)) then 
-      return 
+    if (c_associated(ph%item)) then
+      res = 0
+      return
     end if
 
     allocate(precp,stat=info)
     if (info /= 0) return
-    
+
     ph%item = c_loc(precp)
 
     call stringc2f(ptype,fptype)
-    
-    call precp%init(ictxt,fptype,info) 
-     
+
+    call precp%init(ictxt,fptype,info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
@@ -58,9 +58,9 @@ contains
   function  mld_c_dprecseti(ph,what,val) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type) :: ph
     character(c_char)     :: what(*)
     integer(psb_c_ipk_), value :: val
@@ -69,28 +69,28 @@ contains
     type(mld_dprec_type), pointer  :: precp
 
     res = -1
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
     call stringc2f(what,fwhat)
 
-    call mld_precset(precp,fwhat,val,info) 
-     
+    call mld_precset(precp,fwhat,val,info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
   end function mld_c_dprecseti
-    
+
 
   function  mld_c_dprecsetr(ph,what,val) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type) :: ph
     character(c_char)     :: what(*)
     real(c_double), value :: val
@@ -99,27 +99,27 @@ contains
     type(mld_dprec_type), pointer  :: precp
 
     res = -1
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
     call stringc2f(what,fwhat)
 
-    call mld_precset(precp,fwhat,val,info) 
-     
+    call mld_precset(precp,fwhat,val,info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
   end function mld_c_dprecsetr
-  
+
   function  mld_c_dprecsetc(ph,what,val) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type) :: ph
     character(c_char)     :: what(*), val(*)
     integer               :: info
@@ -127,17 +127,17 @@ contains
     type(mld_dprec_type), pointer  :: precp
 
     res = -1
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
     call stringc2f(what,fwhat)
     call stringc2f(val,fval)
 
-    call mld_precset(precp,fwhat,fval,info) 
-     
+    call mld_precset(precp,fwhat,fval,info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
@@ -146,9 +146,9 @@ contains
   function  mld_c_dprecbld(ah,cdh,ph) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
     integer               :: info
     type(mld_dprec_type), pointer  :: precp
@@ -158,36 +158,36 @@ contains
 
     res = -1
 
-    if (c_associated(cdh%item)) then 
+    if (c_associated(cdh%item)) then
       call c_f_pointer(cdh%item,descp)
     else
-      return 
+      return
     end if
-    if (c_associated(ah%item)) then 
+    if (c_associated(ah%item)) then
       call c_f_pointer(ah%item,ap)
     else
-      return 
+      return
     end if
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-    call mld_precbld(ap,descp,precp,info) 
+    call mld_precbld(ap,descp,precp,info)
 
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
 
     return
   end function mld_c_dprecbld
-    
+
   function  mld_c_dhierarchy_build(ah,cdh,ph) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
     integer               :: info
     type(mld_dprec_type), pointer  :: precp
@@ -197,23 +197,23 @@ contains
 
     res = -1
 
-    if (c_associated(cdh%item)) then 
+    if (c_associated(cdh%item)) then
       call c_f_pointer(cdh%item,descp)
     else
-      return 
+      return
     end if
-    if (c_associated(ah%item)) then 
+    if (c_associated(ah%item)) then
       call c_f_pointer(ah%item,ap)
     else
-      return 
+      return
     end if
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-    call precp%hierarchy_build(ap,descp,info) 
+    call precp%hierarchy_build(ap,descp,info)
 
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
@@ -224,9 +224,9 @@ contains
   function  mld_c_dsmoothers_build(ah,cdh,ph) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
     integer               :: info
     type(mld_dprec_type), pointer  :: precp
@@ -236,30 +236,30 @@ contains
 
     res = -1
 
-    if (c_associated(cdh%item)) then 
+    if (c_associated(cdh%item)) then
       call c_f_pointer(cdh%item,descp)
     else
-      return 
+      return
     end if
-    if (c_associated(ah%item)) then 
+    if (c_associated(ah%item)) then
       call c_f_pointer(ah%item,ap)
     else
-      return 
+      return
     end if
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-    call precp%smoothers_build(ap,descp,info) 
+    call precp%smoothers_build(ap,descp,info)
 
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
 
     return
   end function mld_c_dsmoothers_build
-    
+
   function  mld_c_dkrylov(methd,&
        & ah,ph,bh,xh,cdh,options) bind(c) result(res)
     use psb_base_mod
@@ -267,17 +267,17 @@ contains
     use psb_krylov_mod
     use psb_prec_cbind_mod
     use psb_dkrylov_cbind_mod
-    implicit none 
+    implicit none
     integer(psb_c_ipk_)          :: res
     type(psb_c_object_type) :: ah,cdh,ph,bh,xh
     character(c_char)       :: methd(*)
     type(solveroptions)     :: options
-    
+
     res= mld_c_dkrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh,  &
          & itmax=options%itmax, iter=options%iter,&
          & itrace=options%itrace, istop=options%istop,&
          & irst=options%irst, err=options%err)
-    
+
   end function mld_c_dkrylov
 
 
@@ -289,7 +289,7 @@ contains
     use psb_objhandle_mod
     use psb_prec_cbind_mod
     use psb_base_string_cbind_mod
-    implicit none 
+    implicit none
     integer(psb_c_ipk_)          :: res
     type(psb_c_object_type) :: ah,cdh,ph,bh,xh
     integer(psb_c_ipk_), value :: itmax,itrace,irst,istop
@@ -307,33 +307,33 @@ contains
     real(kind(1.d0))      :: feps,ferr
 
     res = -1
-    if (c_associated(cdh%item)) then 
+    if (c_associated(cdh%item)) then
       call c_f_pointer(cdh%item,descp)
     else
-      return 
+      return
     end if
-    if (c_associated(xh%item)) then 
+    if (c_associated(xh%item)) then
       call c_f_pointer(xh%item,xp)
     else
-      return 
+      return
     end if
-    if (c_associated(bh%item)) then 
+    if (c_associated(bh%item)) then
       call c_f_pointer(bh%item,bp)
     else
-      return 
+      return
     end if
-    if (c_associated(ah%item)) then 
+    if (c_associated(ah%item)) then
       call c_f_pointer(ah%item,ap)
     else
-      return 
+      return
     end if
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-    
+
     call stringc2f(methd,fmethd)
     feps    = eps
     fitmax  = itmax
@@ -348,34 +348,33 @@ contains
     iter = fiter
     err  = ferr
     res = min(info,0)
-    
+
   end function mld_c_dkrylov_opt
 
   function  mld_c_dprecfree(ph) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type) :: ph
     integer               :: info
     type(mld_dprec_type), pointer :: precp
     character(len=80)     :: fptype
 
     res = -1
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-        
-    call precp%free(info) 
-     
+
+    call precp%free(info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
   end function mld_c_dprecfree
 
 end module mld_dprec_cbind_mod
-

cbind/mlprec/mld_zprec_cbind_mod.F90

@@ -8,7 +8,7 @@ module mld_zprec_cbind_mod
     type(c_ptr) :: item = c_null_ptr
   end type mld_c_zprec
 
-contains 
+contains
 
 #if 1
 #define MLDC_DEBUG(MSG) write(*,*) __FILE__,':',__LINE__,':',MSG
@@ -21,13 +21,13 @@ contains
 !#define MLDC_ERR_FILTER(INFO) min(0,INFO)
 #define MLDC_ERR_FILTER(INFO) (INFO)
 #define MLDC_ERR_HANDLE(INFO) if(INFO/=mld_success_)MLDC_ERROR("ERROR!")
-    
+
   function  mld_c_zprecinit(ictxt,ph,ptype) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_)  :: res   
+    implicit none
+
+    integer(psb_c_ipk_)  :: res
     type(mld_c_zprec)    :: ph
     integer(psb_c_ipk_), value :: ictxt
     character(c_char)     :: ptype(*)
@@ -36,20 +36,20 @@ contains
     character(len=80)     :: fptype
 
     res = -1
-    res = -1
-    if (c_associated(ph%item)) then 
-      return 
+    if (c_associated(ph%item)) then
+      res = 0
+      return
     end if
 
     allocate(precp,stat=info)
     if (info /= 0) return
-    
+
     ph%item = c_loc(precp)
 
     call stringc2f(ptype,fptype)
-    
-    call precp%init(ictxt,fptype,info) 
-     
+
+    call precp%init(ictxt,fptype,info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
@@ -58,9 +58,9 @@ contains
   function  mld_c_zprecseti(ph,what,val) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type) :: ph
     character(c_char)     :: what(*)
     integer(psb_c_ipk_), value :: val
@@ -69,28 +69,28 @@ contains
     type(mld_zprec_type), pointer  :: precp
 
     res = -1
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
     call stringc2f(what,fwhat)
 
-    call mld_precset(precp,fwhat,val,info) 
-     
+    call mld_precset(precp,fwhat,val,info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
   end function mld_c_zprecseti
-    
+
 
   function  mld_c_zprecsetr(ph,what,val) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type) :: ph
     character(c_char)     :: what(*)
     real(c_double), value :: val
@@ -99,27 +99,27 @@ contains
     type(mld_zprec_type), pointer  :: precp
 
     res = -1
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
     call stringc2f(what,fwhat)
 
-    call mld_precset(precp,fwhat,val,info) 
-     
+    call mld_precset(precp,fwhat,val,info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
   end function mld_c_zprecsetr
-  
+
   function  mld_c_zprecsetc(ph,what,val) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type) :: ph
     character(c_char)     :: what(*), val(*)
     integer               :: info
@@ -127,17 +127,17 @@ contains
     type(mld_zprec_type), pointer  :: precp
 
     res = -1
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
     call stringc2f(what,fwhat)
     call stringc2f(val,fval)
 
-    call mld_precset(precp,fwhat,fval,info) 
-     
+    call mld_precset(precp,fwhat,fval,info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
@@ -146,9 +146,9 @@ contains
   function  mld_c_zprecbld(ah,cdh,ph) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
     integer               :: info
     type(mld_zprec_type), pointer  :: precp
@@ -158,36 +158,36 @@ contains
 
     res = -1
 
-    if (c_associated(cdh%item)) then 
+    if (c_associated(cdh%item)) then
       call c_f_pointer(cdh%item,descp)
     else
-      return 
+      return
     end if
-    if (c_associated(ah%item)) then 
+    if (c_associated(ah%item)) then
       call c_f_pointer(ah%item,ap)
     else
-      return 
+      return
     end if
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-    call mld_precbld(ap,descp,precp,info) 
+    call mld_precbld(ap,descp,precp,info)
 
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
 
     return
   end function mld_c_zprecbld
-    
+
   function  mld_c_zhierarchy_build(ah,cdh,ph) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
     integer               :: info
     type(mld_zprec_type), pointer  :: precp
@@ -197,23 +197,23 @@ contains
 
     res = -1
 
-    if (c_associated(cdh%item)) then 
+    if (c_associated(cdh%item)) then
       call c_f_pointer(cdh%item,descp)
     else
-      return 
+      return
     end if
-    if (c_associated(ah%item)) then 
+    if (c_associated(ah%item)) then
       call c_f_pointer(ah%item,ap)
     else
-      return 
+      return
     end if
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-    call precp%hierarchy_build(ap,descp,info) 
+    call precp%hierarchy_build(ap,descp,info)
 
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
@@ -224,9 +224,9 @@ contains
   function  mld_c_zsmoothers_build(ah,cdh,ph) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
     integer               :: info
     type(mld_zprec_type), pointer  :: precp
@@ -236,30 +236,30 @@ contains
 
     res = -1
 
-    if (c_associated(cdh%item)) then 
+    if (c_associated(cdh%item)) then
       call c_f_pointer(cdh%item,descp)
     else
-      return 
+      return
     end if
-    if (c_associated(ah%item)) then 
+    if (c_associated(ah%item)) then
       call c_f_pointer(ah%item,ap)
     else
-      return 
+      return
     end if
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-    call precp%smoothers_build(ap,descp,info) 
+    call precp%smoothers_build(ap,descp,info)
 
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
 
     return
   end function mld_c_zsmoothers_build
-    
+
   function  mld_c_zkrylov(methd,&
        & ah,ph,bh,xh,cdh,options) bind(c) result(res)
     use psb_base_mod
@@ -267,17 +267,17 @@ contains
     use psb_krylov_mod
     use psb_prec_cbind_mod
     use psb_zkrylov_cbind_mod
-    implicit none 
+    implicit none
     integer(psb_c_ipk_)          :: res
     type(psb_c_object_type) :: ah,cdh,ph,bh,xh
     character(c_char)       :: methd(*)
     type(solveroptions)     :: options
-    
+
     res= mld_c_zkrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh,  &
          & itmax=options%itmax, iter=options%iter,&
          & itrace=options%itrace, istop=options%istop,&
          & irst=options%irst, err=options%err)
-    
+
   end function mld_c_zkrylov
 
 
@@ -289,7 +289,7 @@ contains
     use psb_objhandle_mod
     use psb_prec_cbind_mod
     use psb_base_string_cbind_mod
-    implicit none 
+    implicit none
     integer(psb_c_ipk_)          :: res
     type(psb_c_object_type) :: ah,cdh,ph,bh,xh
     integer(psb_c_ipk_), value :: itmax,itrace,irst,istop
@@ -307,33 +307,33 @@ contains
     real(kind(1.d0))      :: feps,ferr
 
     res = -1
-    if (c_associated(cdh%item)) then 
+    if (c_associated(cdh%item)) then
       call c_f_pointer(cdh%item,descp)
     else
-      return 
+      return
     end if
-    if (c_associated(xh%item)) then 
+    if (c_associated(xh%item)) then
       call c_f_pointer(xh%item,xp)
     else
-      return 
+      return
     end if
-    if (c_associated(bh%item)) then 
+    if (c_associated(bh%item)) then
       call c_f_pointer(bh%item,bp)
     else
-      return 
+      return
     end if
-    if (c_associated(ah%item)) then 
+    if (c_associated(ah%item)) then
       call c_f_pointer(ah%item,ap)
     else
-      return 
+      return
     end if
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-    
+
     call stringc2f(methd,fmethd)
     feps    = eps
     fitmax  = itmax
@@ -348,34 +348,33 @@ contains
     iter = fiter
     err  = ferr
     res = min(info,0)
-    
+
   end function mld_c_zkrylov_opt
 
   function  mld_c_zprecfree(ph) bind(c) result(res)
     use psb_base_mod
     use mld_prec_mod
-    implicit none 
-    
-    integer(psb_c_ipk_) :: res   
+    implicit none
+
+    integer(psb_c_ipk_) :: res
     type(psb_c_object_type) :: ph
     integer               :: info
     type(mld_zprec_type), pointer :: precp
     character(len=80)     :: fptype
 
     res = -1
-    if (c_associated(ph%item)) then 
+    if (c_associated(ph%item)) then
       call c_f_pointer(ph%item,precp)
     else
-      return 
+      return
     end if
 
-        
-    call precp%free(info) 
-     
+
+    call precp%free(info)
+
     res = MLDC_ERR_FILTER(info)
     MLDC_ERR_HANDLE(res)
     return
   end function mld_c_zprecfree
 
 end module mld_zprec_cbind_mod
-

configure

@@ -666,6 +666,7 @@ am__nodep
 AMDEPBACKSLASH
 AMDEP_FALSE
 AMDEP_TRUE
+am__quote
 am__include
 DEPDIR
 ac_ct_CC
@@ -724,6 +725,7 @@ infodir
 docdir
 oldincludedir
 includedir
+runstatedir
 localstatedir
 sharedstatedir
 sysconfdir
@@ -742,8 +744,7 @@ PACKAGE_VERSION
 PACKAGE_TARNAME
 PACKAGE_NAME
 PATH_SEPARATOR
-SHELL
-am__quote'
+SHELL'
 ac_subst_files=''
 ac_user_opts='
 enable_option_checking
@@ -835,6 +836,7 @@ datadir='${datarootdir}'
 sysconfdir='${prefix}/etc'
 sharedstatedir='${prefix}/com'
 localstatedir='${prefix}/var'
+runstatedir='${localstatedir}/run'
 includedir='${prefix}/include'
 oldincludedir='/usr/include'
 docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
@@ -1087,6 +1089,15 @@ do
   | -silent | --silent | --silen | --sile | --sil)
     silent=yes ;;
 
+  -runstatedir | --runstatedir | --runstatedi | --runstated \
+  | --runstate | --runstat | --runsta | --runst | --runs \
+  | --run | --ru | --r)
+    ac_prev=runstatedir ;;
+  -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
+  | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
+  | --run=* | --ru=* | --r=*)
+    runstatedir=$ac_optarg ;;
+
   -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
     ac_prev=sbindir ;;
   -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
@@ -1224,7 +1235,7 @@ fi
 for ac_var in	exec_prefix prefix bindir sbindir libexecdir datarootdir \
 		datadir sysconfdir sharedstatedir localstatedir includedir \
 		oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
-		libdir localedir mandir
+		libdir localedir mandir runstatedir
 do
   eval ac_val=\$$ac_var
   # Remove trailing slashes.
@@ -1377,6 +1388,7 @@ Fine tuning of the installation directories:
   --sysconfdir=DIR        read-only single-machine data [PREFIX/etc]
   --sharedstatedir=DIR    modifiable architecture-independent data [PREFIX/com]
   --localstatedir=DIR     modifiable single-machine data [PREFIX/var]
+  --runstatedir=DIR       modifiable per-process data [LOCALSTATEDIR/run]
   --libdir=DIR            object code libraries [EPREFIX/lib]
   --includedir=DIR        C header files [PREFIX/include]
   --oldincludedir=DIR     C header files for non-gcc [/usr/include]
@@ -2665,7 +2677,7 @@ fi
 
 { $as_echo "$as_me:${as_lineno-$LINENO}: Loaded $pac_cv_status_file $FC $MPIFC $BLACS_LIBS" >&5
 $as_echo "$as_me: Loaded $pac_cv_status_file $FC $MPIFC $BLACS_LIBS" >&6;}
-am__api_version='1.16'
+am__api_version='1.15'
 
 ac_aux_dir=
 for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do
@@ -3210,8 +3222,8 @@ MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"}
 
 # For better backward compatibility.  To be removed once Automake 1.9.x
 # dies out for good.  For more background, see:
-# <https://lists.gnu.org/archive/html/automake/2012-07/msg00001.html>
-# <https://lists.gnu.org/archive/html/automake/2012-07/msg00014.html>
+# <http://lists.gnu.org/archive/html/automake/2012-07/msg00001.html>
+# <http://lists.gnu.org/archive/html/automake/2012-07/msg00014.html>
 mkdir_p='$(MKDIR_P)'
 
 # We need awk for the "check" target (and possibly the TAP driver).  The
@@ -3262,7 +3274,7 @@ END
 Aborting the configuration process, to ensure you take notice of the issue.
 
 You can download and install GNU coreutils to get an 'rm' implementation
-that behaves properly: <https://www.gnu.org/software/coreutils/>.
+that behaves properly: <http://www.gnu.org/software/coreutils/>.
 
 If you want to complete the configuration process using your problematic
 'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM
@@ -4161,45 +4173,45 @@ DEPDIR="${am__leading_dot}deps"
 
 ac_config_commands="$ac_config_commands depfiles"
 
-{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} supports the include directive" >&5
-$as_echo_n "checking whether ${MAKE-make} supports the include directive... " >&6; }
-cat > confinc.mk << 'END'
+
+am_make=${MAKE-make}
+cat > confinc << 'END'
 am__doit:
-	@echo this is the am__doit target >confinc.out
+	@echo this is the am__doit target
 .PHONY: am__doit
 END
+# If we don't find an include directive, just comment out the code.
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for style of include used by $am_make" >&5
+$as_echo_n "checking for style of include used by $am_make... " >&6; }
 am__include="#"
 am__quote=
-# BSD make does it like this.
-echo '.include "confinc.mk" # ignored' > confmf.BSD
-# Other make implementations (GNU, Solaris 10, AIX) do it like this.
-echo 'include confinc.mk # ignored' > confmf.GNU
-_am_result=no
-for s in GNU BSD; do
-  { echo "$as_me:$LINENO: ${MAKE-make} -f confmf.$s && cat confinc.out" >&5
-   (${MAKE-make} -f confmf.$s && cat confinc.out) >&5 2>&5
-   ac_status=$?
-   echo "$as_me:$LINENO: \$? = $ac_status" >&5
-   (exit $ac_status); }
-  case $?:`cat confinc.out 2>/dev/null` in #(
-  '0:this is the am__doit target') :
-    case $s in #(
-  BSD) :
-    am__include='.include' am__quote='"' ;; #(
-  *) :
-    am__include='include' am__quote='' ;;
-esac ;; #(
-  *) :
-     ;;
+_am_result=none
+# First try GNU make style include.
+echo "include confinc" > confmf
+# Ignore all kinds of additional output from 'make'.
+case `$am_make -s -f confmf 2> /dev/null` in #(
+*the\ am__doit\ target*)
+  am__include=include
+  am__quote=
+  _am_result=GNU
+  ;;
 esac
-  if test "$am__include" != "#"; then
-    _am_result="yes ($s style)"
-    break
-  fi
-done
-rm -f confinc.* confmf.*
-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: ${_am_result}" >&5
-$as_echo "${_am_result}" >&6; }
+# Now try BSD make style include.
+if test "$am__include" = "#"; then
+   echo '.include "confinc"' > confmf
+   case `$am_make -s -f confmf 2> /dev/null` in #(
+   *the\ am__doit\ target*)
+     am__include=.include
+     am__quote="\""
+     _am_result=BSD
+     ;;
+   esac
+fi
+
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $_am_result" >&5
+$as_echo "$_am_result" >&6; }
+rm -f confinc confmf
 
 # Check whether --enable-dependency-tracking was given.
 if test "${enable_dependency_tracking+set}" = set; then :
@@ -10111,7 +10123,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
 #
 # INIT-COMMANDS
 #
-AMDEP_TRUE="$AMDEP_TRUE" MAKE="${MAKE-make}"
+AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir"
 
 _ACEOF
 
@@ -10556,35 +10568,29 @@ $as_echo "$as_me: executing $ac_file commands" >&6;}
   # Older Autoconf quotes --file arguments for eval, but not when files
   # are listed without --file.  Let's play safe and only enable the eval
   # if we detect the quoting.
-  # TODO: see whether this extra hack can be removed once we start
-  # requiring Autoconf 2.70 or later.
-  case $CONFIG_FILES in #(
-  *\'*) :
-    eval set x "$CONFIG_FILES" ;; #(
-  *) :
-    set x $CONFIG_FILES ;; #(
-  *) :
-     ;;
-esac
+  case $CONFIG_FILES in
+  *\'*) eval set x "$CONFIG_FILES" ;;
+  *)   set x $CONFIG_FILES ;;
+  esac
   shift
-  # Used to flag and report bootstrapping failures.
-  am_rc=0
-  for am_mf
+  for mf
   do
     # Strip MF so we end up with the name of the file.
-    am_mf=`$as_echo "$am_mf" | sed -e 's/:.*$//'`
-    # Check whether this is an Automake generated Makefile which includes
-    # dependency-tracking related rules and includes.
-    # Grep'ing the whole file directly is not great: AIX grep has a line
+    mf=`echo "$mf" | sed -e 's/:.*$//'`
+    # Check whether this is an Automake generated Makefile or not.
+    # We used to match only the files named 'Makefile.in', but
+    # some people rename them; so instead we look at the file content.
+    # Grep'ing the first line is not enough: some people post-process
+    # each Makefile.in and add a new line on top of each file to say so.
+    # Grep'ing the whole file is not good either: AIX grep has a line
     # limit of 2048, but all sed's we know have understand at least 4000.
-    sed -n 's,^am--depfiles:.*,X,p' "$am_mf" | grep X >/dev/null 2>&1 \
-      || continue
-    am_dirpart=`$as_dirname -- "$am_mf" ||
-$as_expr X"$am_mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
-	 X"$am_mf" : 'X\(//\)[^/]' \| \
-	 X"$am_mf" : 'X\(//\)$' \| \
-	 X"$am_mf" : 'X\(/\)' \| . 2>/dev/null ||
-$as_echo X"$am_mf" |
+    if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then
+      dirpart=`$as_dirname -- "$mf" ||
+$as_expr X"$mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+	 X"$mf" : 'X\(//\)[^/]' \| \
+	 X"$mf" : 'X\(//\)$' \| \
+	 X"$mf" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X"$mf" |
     sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
 	    s//\1/
 	    q
@@ -10602,48 +10608,53 @@ $as_echo X"$am_mf" |
 	    q
 	  }
 	  s/.*/./; q'`
-    am_filepart=`$as_basename -- "$am_mf" ||
-$as_expr X/"$am_mf" : '.*/\([^/][^/]*\)/*$' \| \
-	 X"$am_mf" : 'X\(//\)$' \| \
-	 X"$am_mf" : 'X\(/\)' \| . 2>/dev/null ||
-$as_echo X/"$am_mf" |
-    sed '/^.*\/\([^/][^/]*\)\/*$/{
+    else
+      continue
+    fi
+    # Extract the definition of DEPDIR, am__include, and am__quote
+    # from the Makefile without running 'make'.
+    DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"`
+    test -z "$DEPDIR" && continue
+    am__include=`sed -n 's/^am__include = //p' < "$mf"`
+    test -z "$am__include" && continue
+    am__quote=`sed -n 's/^am__quote = //p' < "$mf"`
+    # Find all dependency output files, they are included files with
+    # $(DEPDIR) in their names.  We invoke sed twice because it is the
+    # simplest approach to changing $(DEPDIR) to its actual value in the
+    # expansion.
+    for file in `sed -n "
+      s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \
+	 sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g'`; do
+      # Make sure the directory exists.
+      test -f "$dirpart/$file" && continue
+      fdir=`$as_dirname -- "$file" ||
+$as_expr X"$file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+	 X"$file" : 'X\(//\)[^/]' \| \
+	 X"$file" : 'X\(//\)$' \| \
+	 X"$file" : 'X\(/\)' \| . 2>/dev/null ||
+$as_echo X"$file" |
+    sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
 	    s//\1/
 	    q
 	  }
-	  /^X\/\(\/\/\)$/{
+	  /^X\(\/\/\)[^/].*/{
 	    s//\1/
 	    q
 	  }
-	  /^X\/\(\/\).*/{
+	  /^X\(\/\/\)$/{
+	    s//\1/
+	    q
+	  }
+	  /^X\(\/\).*/{
 	    s//\1/
 	    q
 	  }
 	  s/.*/./; q'`
-    { echo "$as_me:$LINENO: cd "$am_dirpart" \
-      && sed -e '/# am--include-marker/d' "$am_filepart" \
-        | $MAKE -f - am--depfiles" >&5
-   (cd "$am_dirpart" \
-      && sed -e '/# am--include-marker/d' "$am_filepart" \
-        | $MAKE -f - am--depfiles) >&5 2>&5
-   ac_status=$?
-   echo "$as_me:$LINENO: \$? = $ac_status" >&5
-   (exit $ac_status); } || am_rc=$?
+      as_dir=$dirpart/$fdir; as_fn_mkdir_p
+      # echo "creating $dirpart/$file"
+      echo '# dummy' > "$dirpart/$file"
+    done
   done
-  if test $am_rc -ne 0; then
-    { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
-$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
-as_fn_error $? "Something went wrong bootstrapping makefile fragments
-    for automatic dependency tracking.  Try re-running configure with the
-    '--disable-dependency-tracking' option to at least be able to build
-    the package (albeit without support for automatic dependency tracking).
-See \`config.log' for more details" "$LINENO" 5; }
-  fi
-  { am_dirpart=; unset am_dirpart;}
-  { am_filepart=; unset am_filepart;}
-  { am_mf=; unset am_mf;}
-  { am_rc=; unset am_rc;}
-  rm -f conftest-deps.mk
 }
  ;;
 

mlprec/impl/aggregator/Makefile

@@ -14,42 +14,34 @@ mld_s_dec_aggregator_mat_bld.o \
 mld_s_dec_aggregator_tprol.o \
 mld_s_symdec_aggregator_tprol.o  \
 mld_s_map_to_tprol.o mld_s_soc1_map_bld.o mld_s_soc2_map_bld.o\
-mld_s_spmm_bld_inner.o \
-mld_saggrmat_biz_bld.o mld_saggrmat_minnrg_bld.o\
+mld_s_ptap.o \
+mld_saggrmat_minnrg_bld.o\
 mld_saggrmat_nosmth_bld.o mld_saggrmat_smth_bld.o \
 mld_d_dec_aggregator_mat_asb.o \
 mld_d_dec_aggregator_mat_bld.o \
 mld_d_dec_aggregator_tprol.o \
 mld_d_symdec_aggregator_tprol.o  \
 mld_d_map_to_tprol.o mld_d_soc1_map_bld.o mld_d_soc2_map_bld.o \
-mld_d_spmm_bld_inner.o \
-mld_daggrmat_biz_bld.o mld_daggrmat_minnrg_bld.o \
+mld_d_ptap.o \
+mld_daggrmat_minnrg_bld.o \
 mld_daggrmat_nosmth_bld.o mld_daggrmat_smth_bld.o \
 mld_c_dec_aggregator_mat_asb.o \
 mld_c_dec_aggregator_mat_bld.o \
 mld_c_dec_aggregator_tprol.o \
 mld_c_symdec_aggregator_tprol.o  \
 mld_c_map_to_tprol.o mld_c_soc1_map_bld.o mld_c_soc2_map_bld.o\
-mld_c_spmm_bld_inner.o \
-mld_caggrmat_biz_bld.o mld_caggrmat_minnrg_bld.o\
+mld_c_ptap.o \
+mld_caggrmat_minnrg_bld.o\
 mld_caggrmat_nosmth_bld.o mld_caggrmat_smth_bld.o \
 mld_z_dec_aggregator_mat_asb.o \
 mld_z_dec_aggregator_mat_bld.o \
 mld_z_dec_aggregator_tprol.o \
 mld_z_symdec_aggregator_tprol.o  \
 mld_z_map_to_tprol.o mld_z_soc1_map_bld.o mld_z_soc2_map_bld.o\
-mld_z_spmm_bld_inner.o \
-mld_zaggrmat_biz_bld.o mld_zaggrmat_minnrg_bld.o\
+mld_z_ptap.o \
+mld_zaggrmat_minnrg_bld.o\
 mld_zaggrmat_nosmth_bld.o mld_zaggrmat_smth_bld.o 
 
-#mld_s_hybrid_aggregator_tprol.o \
-#mld_d_hybrid_aggregator_tprol.o \
-#mld_c_hybrid_aggregator_tprol.o \
-#mld_z_hybrid_aggregator_tprol.o \
-
-#bootCMatch_interface.o mld_d_bcmatch_aggregator_tprol.o\
-#mld_d_bcmatch_map_to_tprol.o mld_d_bcmatch_aggregator_mat_bld.o \
-
 
 LIBNAME=libmld_prec.a
 

mlprec/impl/aggregator/mld_c_dec_aggregator_mat_asb.f90

@@ -83,7 +83,7 @@
 !    info       -  integer, output.
 !                  Error code.
 !  
-subroutine  mld_c_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
+subroutine  mld_c_dec_aggregator_mat_asb(ag,parms,a,desc_a,&
      & ac,desc_ac, op_prol,op_restr,info)
   use psb_base_mod
   use mld_base_prec_type
@@ -93,16 +93,13 @@ subroutine  mld_c_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   type(mld_sml_parms), intent(inout)  :: parms 
   type(psb_cspmat_type), intent(in)    :: a
   type(psb_desc_type), intent(inout)     :: desc_a
-  integer(psb_lpk_), intent(inout)       :: ilaggr(:), nlaggr(:)
-  type(psb_lcspmat_type), intent(inout) :: op_prol, ac,op_restr
+  type(psb_cspmat_type), intent(inout) :: op_prol, ac,op_restr
   type(psb_desc_type), intent(inout)     :: desc_ac
   integer(psb_ipk_), intent(out)         :: info
   !
   integer(psb_ipk_)              :: ictxt, np, me
-  type(psb_lc_coo_sparse_mat)  :: lacoo, lbcoo
-  type(psb_c_coo_sparse_mat)   :: acoo
-  type(psb_lc_csr_sparse_mat)  :: acsr1
-  type(psb_cspmat_type)        :: tmp_ac
+  type(psb_lc_coo_sparse_mat)  :: tmpcoo
+  type(psb_lcspmat_type)       :: tmp_ac
   integer(psb_ipk_)              :: i_nr, i_nc, i_nl, nzl
   integer(psb_lpk_)              :: ntaggr
   integer(psb_ipk_) :: err_act, debug_level, debug_unit
@@ -117,70 +114,13 @@ subroutine  mld_c_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   ictxt = desc_a%get_context()
   call psb_info(ictxt,me,np)
 
-
-
-  ntaggr = sum(nlaggr)
-
   select case(parms%coarse_mat)
 
   case(mld_distr_mat_) 
 
-    call ac%mv_to(lbcoo)
-    nzl  = lbcoo%get_nzeros()
-    i_nl = nlaggr(me+1)
-    if (info == psb_success_) call psb_cdall(ictxt,desc_ac,info,nl=i_nl)
-    if (info == psb_success_) call psb_cdins(nzl,lbcoo%ia,lbcoo%ja,desc_ac,info)
-    if (info == psb_success_) call psb_cdasb(desc_ac,info)
-    if (info == psb_success_) call psb_glob_to_loc(lbcoo%ia(1:nzl),desc_ac,info,iact='I')
-    if (info == psb_success_) call psb_glob_to_loc(lbcoo%ja(1:nzl),desc_ac,info,iact='I')
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Creating desc_ac and converting ac')
-      goto 9999
-    end if
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Assembld aux descr. distr.'
-    call ac%mv_from(lbcoo)
-    call ac%set_nrows(desc_ac%get_local_rows())
-    call ac%set_ncols(desc_ac%get_local_cols())
-    call ac%set_asb()
-
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
-      goto 9999
-    end if
-
-    if (np>1) then 
-      call op_prol%mv_to(acsr1)
-      nzl = acsr1%get_nzeros()
-      call psb_glob_to_loc(acsr1%ja(1:nzl),desc_ac,info,'I')
-      if(info /= psb_success_) then
-        call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
-        goto 9999
-      end if
-      call op_prol%mv_from(acsr1)
-    endif
-    call op_prol%set_ncols(desc_ac%get_local_cols())
-
-    if (np>1) then 
-      !call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
-      call op_restr%mv_to(lacoo)
-      nzl = lacoo%get_nzeros()
-      if (info == psb_success_) call psb_glob_to_loc(lacoo%ia(1:nzl),desc_ac,info,'I')
-      call lacoo%set_dupl(psb_dupl_add_)
-      if (info == psb_success_) call op_restr%mv_from(lacoo)
-      if (info == psb_success_) call op_restr%cscnv(info,type='csr')        
-      if(info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Converting op_restr to local')
-        goto 9999
-      end if
-    end if
-    !
-    ! Clip to local rows.
-    !
-    call op_restr%set_nrows(desc_ac%get_local_rows())
+    call ac%cscnv(info,type='csr')
+    call op_prol%cscnv(info,type='csr')
+    call op_restr%cscnv(info,type='csr')
 
     if (debug_level >= psb_debug_outer_) &
          & write(debug_unit,*) me,' ',trim(name),&
@@ -188,23 +128,39 @@ subroutine  mld_c_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
 
   case(mld_repl_mat_) 
     !
+    ! We are assuming here that an c matrix
+    ! can hold all entries
     !
-    ! If we are here, it means we assume that an IPK version of the
-    ! coarse matrix can hold all indices. User beware!
-    !
+    if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
+      ntaggr = desc_ac%get_global_rows()
+      i_nr   = ntaggr
+    else
+      info = psb_err_internal_error_
+      call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
+      goto 9999
+    end if
+    
+    call op_prol%mv_to(tmpcoo)
+    nzl = tmpcoo%get_nzeros()
+    call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
+    call tmpcoo%set_ncols(i_nr)
+    call op_prol%mv_from(tmpcoo)
+
+    call op_restr%mv_to(tmpcoo)
+    nzl = tmpcoo%get_nzeros()
+    call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
+    call tmpcoo%set_nrows(i_nr)
+    call op_restr%mv_from(tmpcoo)
+
+
+    call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
+         & dupl=psb_dupl_add_,keeploc=.false.)
+    call tmp_ac%mv_to(tmpcoo)
+    call ac%mv_from(tmpcoo)
     
-    !
-    ! op_prol/op_restr come from par_spmm_bld with local sizes
-    ! suitable for DIST option, fix relevant sizes
-    ! 
-    call op_prol%set_ncols(ntaggr)
-    call op_restr%set_nrows(ntaggr)
     call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
     if (info == psb_success_) call psb_cdasb(desc_ac,info)
-    if (info == psb_success_) call ac%mv_to(acoo)
-    if (info == psb_success_) call tmp_ac%mv_from(acoo)
-    if (info == psb_success_) &
-         & call psb_gather(ac,tmp_ac,desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)     
+
     if (info /= psb_success_) goto 9999
 
   case default 
@@ -221,4 +177,19 @@ subroutine  mld_c_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   return
 
 
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_lc_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
 end subroutine mld_c_dec_aggregator_mat_asb

mlprec/impl/aggregator/mld_c_dec_aggregator_mat_bld.f90

@@ -133,7 +133,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !  
-subroutine  mld_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_prol,op_restr,info)
+subroutine  mld_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_c_prec_type, mld_protect_name => mld_c_dec_aggregator_mat_bld
   use mld_c_inner_mod 
@@ -144,15 +145,14 @@ subroutine  mld_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_p
   type(psb_cspmat_type), intent(in)    :: a
   type(psb_desc_type), intent(inout)     :: desc_a
   integer(psb_lpk_), intent(inout)     :: ilaggr(:), nlaggr(:)
-  type(psb_lcspmat_type), intent(inout)   :: op_prol
-  type(psb_lcspmat_type), intent(out)   :: ac,op_restr
+  type(psb_lcspmat_type), intent(inout)   :: t_prol
+  type(psb_cspmat_type), intent(out)   :: op_prol,ac,op_restr
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)       :: info
 
   ! Local variables
   character(len=20)            :: name
   integer(psb_mpk_)            :: ictxt, np, me
-  type(psb_lc_coo_sparse_mat) :: acoo, bcoo
-  type(psb_lc_csr_sparse_mat) :: acsr1
   integer(psb_lpk_)            :: nzl,ntaggr
   integer(psb_ipk_)            :: err_act
   integer(psb_ipk_)            :: debug_level, debug_unit
@@ -177,22 +177,22 @@ subroutine  mld_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_p
   case (mld_no_smooth_) 
 
     call mld_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,&
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case(mld_smooth_prol_) 
 
     call mld_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
-  case(mld_biz_prol_) 
-
-    call mld_caggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+!!$  case(mld_biz_prol_) 
+!!$
+!!$    call mld_caggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
+!!$         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case(mld_min_energy_) 
 
     call mld_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case default
     info = psb_err_internal_error_

mlprec/impl/aggregator/mld_c_dec_aggregator_tprol.f90

@@ -68,14 +68,14 @@
 !                  overlap.
 !    nlaggr     -  integer, dimension(:), allocatable, output
 !                  nlaggr(i) contains the aggregates held by process i.
-!    op_prol    -  type(psb_cspmat_type), output
+!    t_prol    -  type(psb_cspmat_type), output
 !               The tentative prolongator, based on ilaggr.
 !               
 !    info    -  integer, output.
 !               Error code.         
 !  
 subroutine  mld_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
-     & a,desc_a,ilaggr,nlaggr,op_prol,info)
+     & a,desc_a,ilaggr,nlaggr,t_prol,info)
   use psb_base_mod
   use mld_c_prec_type, mld_protect_name => mld_c_dec_aggregator_build_tprol
   use mld_c_inner_mod
@@ -86,7 +86,7 @@ subroutine  mld_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
   type(psb_cspmat_type), intent(in)   :: a
   type(psb_desc_type), intent(in)     :: desc_a
   integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
-  type(psb_lcspmat_type), intent(out)  :: op_prol
+  type(psb_lcspmat_type), intent(out)  :: t_prol
   integer(psb_ipk_), intent(out)      :: info
 
   ! Local variables
@@ -123,7 +123,7 @@ subroutine  mld_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
   clean_zeros = ag%do_clean_zeros
   call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
 
-  if (info==psb_success_) call mld_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
+  if (info==psb_success_) call mld_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

mlprec/impl/aggregator/mld_c_map_to_tprol.f90

@@ -124,9 +124,9 @@ subroutine mld_c_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
     goto 9999
   end if
 
-  call tmpcoo%allocate(ncol,ntaggr,ncol)
+  call tmpcoo%allocate(nrow,ntaggr,ncol)
   k = 0 
-  do i=1,ncol
+  do i=1,nrow
     !
     ! Note: at this point, a value ilaggr(i)<=0
     ! tags a "singleton" row, and it has to be

mlprec/impl/aggregator/mld_c_ptap.f90

@@ -0,0 +1,689 @@
+!   
+!   
+!                             MLD2P4  Extensions
+!    
+!    (C) Copyright 2019
+!  
+!                        Salvatore Filippone  Cranfield University
+!        Pasqua D'Ambra         IAC-CNR, Naples, IT
+!   
+!    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.
+!   
+!  
+! File: mld_daggrmat_nosmth_bld.F90
+!
+!
+subroutine mld_c_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_c_inner_mod
+  use mld_c_base_aggregator_mod, mld_protect_name => mld_c_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_c_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)          :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_sml_parms), intent(inout)         :: parms 
+  type(psb_c_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_cspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_lc_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_c_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nglob, ntaggr, naggrm1, naggrp1
+  integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_fmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      call coo_prol%cp_to_coo(coo_restr,info)
+      call coo_restr%set_ncols(desc_ac%get_local_cols())
+      call coo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_c_coo_glob_transpose(coo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call coo_restr%set_nrows(desc_ac%get_local_rows())
+      call coo_restr%set_ncols(desc_ax%get_local_cols())
+!!$      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+!!$           & desc_a%get_local_cols(),desc_ax%get_local_cols(),coo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+    end block
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_coo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_c_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_c_ptap
+
+subroutine mld_c_lc_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_c_inner_mod
+  use mld_c_base_aggregator_mod !, mld_protect_name => mld_c_lc_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_c_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)          :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_sml_parms), intent(inout)         :: parms 
+  type(psb_lc_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_lcspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_lc_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_c_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
+       &  nzt, naggrm1, naggrp1, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_ifmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      type(psb_c_coo_sparse_mat) :: icoo_restr
+
+      call coo_prol%cp_to_icoo(icoo_restr,info)
+      call icoo_restr%set_ncols(desc_ac%get_local_cols())
+      call icoo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_c_coo_glob_transpose(icoo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call icoo_restr%set_nrows(desc_ac%get_local_rows())
+      call icoo_restr%set_ncols(desc_ax%get_local_cols())
+      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+           & desc_a%get_local_cols(),desc_ax%get_local_cols(),icoo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+      call coo_restr%cp_from_icoo(icoo_restr,info)
+    end block
+    call csr_restr%cp_from_lcoo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_lcoo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_lcoo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_lc_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_c_lc_ptap
+
+subroutine mld_lc_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_c_inner_mod
+  use mld_c_base_aggregator_mod!, mld_protect_name => mld_lc_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_lc_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)           :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_sml_parms), intent(inout)         :: parms 
+  type(psb_lc_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_lcspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_lc_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_lc_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
+       &  nzt, naggrm1, naggrp1, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_fmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      type(psb_c_coo_sparse_mat) :: icoo_restr
+
+      call coo_prol%cp_to_icoo(icoo_restr,info)
+      call icoo_restr%set_ncols(desc_ac%get_local_cols())
+      call icoo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_c_coo_glob_transpose(icoo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call icoo_restr%set_nrows(desc_ac%get_local_rows())
+      call icoo_restr%set_ncols(desc_ax%get_local_cols())
+      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+           & desc_a%get_local_cols(),desc_ax%get_local_cols(),icoo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+      call coo_restr%cp_from_icoo(icoo_restr,info)
+    end block
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_coo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  !call coo_restr%mv_from_ifmt(csr_restr,info)
+!!$    call coo_restr%set_nrows(desc_ac%get_local_rows())
+!!$    call coo_restr%set_ncols(desc_a%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_lc_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_lc_ptap

mlprec/impl/aggregator/mld_c_spmm_bld_inner.f90

@@ -1,390 +0,0 @@
-!   
-!   
-!                             MLD2P4  Extensions
-!    
-!    (C) Copyright 2019
-!  
-!                        Salvatore Filippone  Cranfield University
-!        Pasqua D'Ambra         IAC-CNR, Naples, IT
-!   
-!    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.
-!   
-!  
-! File: mld_daggrmat_nosmth_bld.F90
-!
-!
-subroutine mld_c_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,&
-     & coo_prol,desc_cprol,coo_restr,info)
-  use psb_base_mod
-  use mld_c_inner_mod
-  use mld_c_base_aggregator_mod, mld_protect_name => mld_c_spmm_bld_inner
-  implicit none
-
-  ! Arguments
-  type(psb_c_csr_sparse_mat), intent(inout) :: a_csr
-  type(psb_desc_type), intent(in)            :: desc_a
-  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
-  type(mld_sml_parms), intent(inout)         :: parms 
-  type(psb_lc_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
-  type(psb_desc_type), intent(inout)         :: desc_cprol
-  type(psb_lcspmat_type), intent(out)        :: ac
-  integer(psb_ipk_), intent(out)             :: info
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
-  character(len=40)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_lc_coo_sparse_mat) :: ac_coo, tmpcoo
-  type(psb_c_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
-  integer(psb_ipk_) :: debug_level, debug_unit, naggr
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
-       &  nzt, naggrm1, naggrp1, i, k
-  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
-  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
-
-  name='mld_spmm_bld_inner'
-  if(psb_get_errstatus().ne.0) return 
-  info=psb_success_
-  call psb_erractionsave(err_act)
-
-
-  ictxt = desc_a%get_context()
-  icomm = desc_a%get_mpic()
-  call psb_info(ictxt, me, np)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
-
-  naggr   = nlaggr(me+1)
-  ntaggr  = sum(nlaggr)
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1)) 
-  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
-
-  !
-  ! COO_PROL should arrive here with local numbering
-  !
-  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
-       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
-       & nrow,ntaggr,naggr
-
-  call coo_prol%cp_to_ifmt(csr_prol,info)
-
-  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
-       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
-       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols()
-  if (debug) flush(0)
-
-  if (do_timings) call psb_tic(idx_spspmm)
-  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)  
-
-  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
-       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
-       & desc_cprol%get_local_rows(),desc_cprol%get_local_cols()
-
-  !
-  ! Ok first product done.
-  !
-  ! Remember that RESTR must be built from PROL after halo extension,
-  ! which is done above in psb_par_spspmm
-  if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
-       & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
-  call csr_prol%cp_to_lcoo(coo_restr,info)
-!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
-!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
-  call coo_restr%transp()
-  nzl = coo_restr%get_nzeros()
-  call desc_cprol%l2gip(coo_restr%ia(1:nzl),info)
-  i=0
-  !
-  ! Now we have to fix this.  The only rows of the restrictor that are correct 
-  ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-  !
-  do k=1, nzl
-    if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then
-      i = i+1
-      coo_restr%val(i) = coo_restr%val(k)
-      coo_restr%ia(i)  = coo_restr%ia(k)
-      coo_restr%ja(i)  = coo_restr%ja(k)
-    end if
-  end do
-  call coo_restr%set_nzeros(i)
-  call coo_restr%fix(info)
-  call coo_restr%cp_to_coo(tmpcoo,info)
-!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
-
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
-    goto 9999
-  end if
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'starting sphalo/ rwxtd'
-  nzl    = tmpcoo%get_nzeros()    
-  call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_cprol,info,iact='I',owned=.true.)
-  call tmpcoo%clean_negidx(info)
-  nzl  = tmpcoo%get_nzeros()
-  call tmpcoo%set_nrows(desc_cprol%get_local_rows())
-  call tmpcoo%set_ncols(desc_a%get_local_cols())
-!!$    write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros()      
-  call csr_restr%mv_from_lcoo(tmpcoo,info)
-
-  if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
-       & csr_restr%get_nrows(),csr_restr%get_ncols(), &
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols(),&
-       & acsr3%get_nrows(),acsr3%get_ncols()
-  if (do_timings) call psb_tic(idx_spspmm)      
-  call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)      
-  call csr_restr%free()
-  call acsr3%free()
-  call ac_csr%mv_to_lcoo(ac_coo,info)
-  call ac_coo%fix(info)
-  nza    = ac_coo%get_nzeros()
-  if (debug) write(0,*) me,trim(name),' Fixed ac ',&
-       & ac_coo%get_nrows(),ac_coo%get_ncols(), nza
-  call desc_cprol%indxmap%l2gip(ac_coo%ia(1:nza),info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ja(1:nza),info)
-  call ac_coo%set_nrows(ntaggr)
-  call ac_coo%set_ncols(ntaggr)
-  if (debug) write(0,*)  me,' ',trim(name),' Before mv_from',psb_get_errstatus()
-  if (info == 0) call ac%mv_from(ac_coo)
-  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
-  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
-  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
-
-  nza = coo_prol%get_nzeros()
-  call desc_cprol%indxmap%l2gip(coo_prol%ja(1:nza),info)
-  
-  if (debug) then
-    write(0,*) me,' ',trim(name),' Checkpoint at exit'
-    call psb_barrier(ictxt)
-    write(0,*) me,' ',trim(name),' Checkpoint through'
-  end if
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done spmm_bld_inner '
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-  
-end subroutine mld_c_spmm_bld_inner
-
-subroutine mld_lc_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,&
-     & coo_prol,desc_cprol,coo_restr,info)
-  use psb_base_mod
-  use mld_c_inner_mod
-  use mld_c_base_aggregator_mod, mld_protect_name => mld_lc_spmm_bld_inner
-  implicit none
-
-  ! Arguments
-  type(psb_lc_csr_sparse_mat), intent(inout) :: a_csr
-  type(psb_desc_type), intent(in)            :: desc_a
-  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
-  type(mld_sml_parms), intent(inout)         :: parms 
-  type(psb_lc_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
-  type(psb_desc_type), intent(inout)         :: desc_cprol
-  type(psb_lcspmat_type), intent(out)        :: ac
-  integer(psb_ipk_), intent(out)             :: info
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
-  character(len=40)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_lc_coo_sparse_mat) :: ac_coo, tmpcoo
-  type(psb_lc_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
-  integer(psb_ipk_) :: debug_level, debug_unit, naggr
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
-       &  nzt, naggrm1, naggrp1, i, k
-  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
-  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
-
-  name='mld_spmm_bld_inner'
-  if(psb_get_errstatus().ne.0) return 
-  info=psb_success_
-  call psb_erractionsave(err_act)
-
-
-  ictxt = desc_a%get_context()
-  icomm = desc_a%get_mpic()
-  call psb_info(ictxt, me, np)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
-
-  naggr   = nlaggr(me+1)
-  ntaggr  = sum(nlaggr)
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1)) 
-  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
-
-  !
-  ! Here COO_PROL should be with GLOBAL indices on the cols
-  ! and LOCAL indices on the rows. 
-  !
-  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
-       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
-       & nrow,ntaggr,naggr
-
-  call coo_prol%cp_to_fmt(csr_prol,info)
-
-  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
-       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
-       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols()
-  if (debug) flush(0)
-
-  if (do_timings) call psb_tic(idx_spspmm)
-  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)  
-
-  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
-       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
-       & desc_cprol%get_local_rows(),desc_cprol%get_local_cols()
-
-  !
-  ! Ok first product done.
-  !
-  ! Remember that RESTR must be built from PROL after halo extension,
-  ! which is done above in psb_par_spspmm
-  if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
-       & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
-  call csr_prol%cp_to_fmt(coo_restr,info)
-!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
-!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
-  call coo_restr%transp()
-  nzl = coo_restr%get_nzeros()
-  call desc_cprol%l2gip(coo_restr%ia(1:nzl),info)
-  i=0
-  !
-  ! Now we have to fix this.  The only rows of the restrictor that are correct 
-  ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-  !
-  do k=1, nzl
-    if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then
-      i = i+1
-      coo_restr%val(i) = coo_restr%val(k)
-      coo_restr%ia(i)  = coo_restr%ia(k)
-      coo_restr%ja(i)  = coo_restr%ja(k)
-    end if
-  end do
-  call coo_restr%set_nzeros(i)
-  call coo_restr%fix(info)
-  call coo_restr%cp_to_coo(tmpcoo,info)
-!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
-
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
-    goto 9999
-  end if
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'starting sphalo/ rwxtd'
-  nzl    = tmpcoo%get_nzeros()    
-  call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_cprol,info,iact='I',owned=.true.)
-  call tmpcoo%clean_negidx(info)
-  nzl  = tmpcoo%get_nzeros()
-  call tmpcoo%set_nrows(desc_cprol%get_local_rows())
-  call tmpcoo%set_ncols(desc_a%get_local_cols())
-!!$    write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros()      
-  call csr_restr%mv_from_coo(tmpcoo,info)
-
-  if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
-       & csr_restr%get_nrows(),csr_restr%get_ncols(), &
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols(),&
-       & acsr3%get_nrows(),acsr3%get_ncols()
-  if (do_timings) call psb_tic(idx_spspmm)      
-  call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)      
-  call csr_restr%free()
-  call ac_csr%mv_to_coo(ac_coo,info)
-  nza    = ac_coo%get_nzeros()
-  if (debug) write(0,*) me,trim(name),' Fixing ac ',&
-       & ac_coo%get_nrows(),ac_coo%get_ncols(), nza
-  call ac_coo%fix(info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ia(1:nza),info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ja(1:nza),info)
-  call ac_coo%set_nrows(ntaggr)
-  call ac_coo%set_ncols(ntaggr)
-  if (debug) write(0,*)  me,' ',trim(name),' Before mv_from',psb_get_errstatus()
-  if (info == 0) call ac%mv_from(ac_coo)
-  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
-  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
-  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
-
-  nza = coo_prol%get_nzeros()
-  call desc_cprol%indxmap%l2gip(coo_prol%ja(1:nza),info)
-  
-  if (debug) then
-    write(0,*) me,' ',trim(name),' Checkpoint at exit'
-    call psb_barrier(ictxt)
-    write(0,*) me,' ',trim(name),' Checkpoint through'
-  end if
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done spmm_bld_inner '
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-  
-end subroutine mld_lc_spmm_bld_inner

mlprec/impl/aggregator/mld_caggrmat_biz_bld.f90

@@ -1,300 +0,0 @@
-!   
-!   
-!                             MLD2P4  version 2.2
-!    MultiLevel Domain Decomposition Parallel Preconditioners Package
-!               based on PSBLAS (Parallel Sparse BLAS version 3.5)
-!    
-!    (C) Copyright 2008-2018 
-!  
-!        Salvatore Filippone  
-!        Pasqua D'Ambra   
-!        Daniela di Serafino   
-!   
-!    Redistribution and use in source and binary forms, with or without
-!    modification, are permitted provided that the following conditions
-!    are met:
-!      1. Redistributions of source code must retain the above copyright
-!         notice, this list of conditions and the following disclaimer.
-!      2. Redistributions in binary form must reproduce the above copyright
-!         notice, this list of conditions, and the following disclaimer in the
-!         documentation and/or other materials provided with the distribution.
-!      3. The name of the 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.
-!   
-!  
-! File: mld_caggrmat_biz_bld.F90
-!
-! Subroutine: mld_caggrmat_biz_bld
-! Version:    complex
-!
-!  This routine builds a coarse-level matrix A_C from a fine-level matrix A
-!  by using the Galerkin approach, i.e.
-!
-!                               A_C = P_C^T A P_C,
-!
-!  where P_C is a prolongator from the coarse level to the fine one.
-! 
-!  This routine builds A_C according to a "bizarre" aggregation algorithm,
-!  using a "naive" prolongator proposed by the authors of MLD2P4. However, this
-!  prolongator still requires additional analysis and testing and its use is not
-!  recommended.
-!
-!  The coarse-level matrix A_C is distributed among the parallel processes or
-!  replicated on each of them, according to the value of p%parms%coarse_mat,
-!  specified by the user through mld_cprecinit and mld_zprecset.
-!  On output from this routine the entries of AC, op_prol, op_restr
-!  are still in "global numbering" mode; this is fixed in the calling routine
-!  mld_c_lev_aggrmat_bld.
-!
-! Arguments:
-!    a          -  type(psb_cspmat_type), input.     
-!                  The sparse matrix structure containing the local part of
-!                  the fine-level matrix.
-!    desc_a     -  type(psb_desc_type), input.
-!                  The communication descriptor of the fine-level matrix.
-!    p          -  type(mld_c_onelev_type), input/output.
-!                  The 'one-level' data structure that will contain the local
-!                  part of the matrix to be built as well as the information 
-!                  concerning the prolongator and its transpose.
-!    ilaggr     -  integer, dimension(:), allocatable.
-!                  The mapping between the row indices of the coarse-level
-!                  matrix and the row indices of the fine-level matrix.
-!                  ilaggr(i)=j means that node i in the adjacency graph
-!                  of the fine-level matrix is mapped onto node j in the
-!                  adjacency graph of the coarse-level matrix.
-!    nlaggr     -  integer, dimension(:), allocatable.
-!                  nlaggr(i) contains the aggregates held by process i.
-!    info       -  integer, output.
-!                  Error code.
-!
-subroutine mld_caggrmat_biz_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
-  use psb_base_mod
-  use mld_base_prec_type
-  use mld_c_inner_mod, mld_protect_name => mld_caggrmat_biz_bld
-  use mld_c_base_aggregator_mod
-  
-  implicit none
-
-  ! Arguments
-  type(psb_cspmat_type), intent(in)      :: a
-  type(psb_desc_type), intent(in)          :: desc_a
-  integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
-  type(mld_sml_parms), intent(inout)    :: parms 
-  type(psb_lcspmat_type), intent(inout)  :: op_prol
-  type(psb_lcspmat_type), intent(out)    :: ac,op_restr
-  integer(psb_ipk_), intent(out)           :: info
-
-  ! Local variables
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
-       & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
-  integer(psb_ipk_) :: inaggr, nzlp, inrow
-  integer(psb_ipk_) :: ictxt, np, me
-  character(len=20) :: name
-  type(psb_desc_type) :: tmp_desc
-  type(psb_c_coo_sparse_mat)  :: icoo
-  type(psb_lc_coo_sparse_mat) :: coo_prol, coo_restr, tmpcoo
-  type(psb_lc_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
-  complex(psb_spk_), allocatable :: adiag(:)
-  real(psb_spk_), allocatable :: arwsum(:)
-  integer(psb_ipk_)  :: ierr(5)
-  logical            :: filter_mat
-  integer(psb_ipk_)            :: debug_level, debug_unit, err_act
-  integer(psb_ipk_), parameter :: ncmax=16
-  real(psb_spk_)     :: anorm, omega, tmp, dg, theta
-  logical, parameter :: debug_new=.false.
-  character(len=80) :: filename
-
-  name='mld_aggrmat_biz_bld'
-  info=psb_success_
-  call psb_erractionsave(err_act)
-  if (psb_errstatus_fatal()) then
-    info = psb_err_internal_error_; goto 9999
-  end if
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-
-  ictxt = desc_a%get_context()
-
-  call psb_info(ictxt, me, np)
-
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  theta = parms%aggr_thresh
-
-  naggr  = nlaggr(me+1)
-  ntaggr = sum(nlaggr)
-
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1))
-  filter_mat = (parms%aggr_filter == mld_filter_mat_)
-
-  !
-  ! naggr: number of local aggregates
-  ! nrow: local rows. 
-  ! 
-
-  ! Get the diagonal D
-  adiag = a%get_diag(info)
-  if (info == psb_success_) &
-       & call psb_realloc(ncol,adiag,info)
-  if (info == psb_success_) &
-       & call psb_halo(adiag,desc_a,info)
-  if (info == psb_success_) call a%csclip(icoo,info,jmax=a%get_nrows())
-  call icoo%mv_to_lfmt(acsr,info)
-  call op_prol%mv_to(coo_prol)
-
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
-    goto 9999
-  end if
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & ' Initial copies done.'
-
-  call acsr%cp_to_fmt(acsrf,info)
-
-
-  if (filter_mat) then
-    !
-    ! Build the filtered matrix Af from A
-    ! 
-
-    do i=1, nrow
-      tmp = czero
-      jd  = -1 
-      do j=acsrf%irp(i),acsrf%irp(i+1)-1
-        if (acsrf%ja(j) == i) jd = j 
-        if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
-          tmp=tmp+acsrf%val(j)
-          acsrf%val(j)=czero
-        endif
-
-      enddo
-      if (jd == -1) then 
-        write(0,*) 'Wrong input: we need the diagonal!!!!', i
-      else
-        acsrf%val(jd)=acsrf%val(jd)-tmp
-      end if
-    enddo
-    ! Take out zeroed terms 
-    call acsrf%clean_zeros(info)
-  end if
-
-
-  do i=1,size(adiag)
-    if (adiag(i) /= czero) then
-      adiag(i) = cone / adiag(i)
-    else
-      adiag(i) = cone
-    end if
-  end do
-
-  if (parms%aggr_omega_alg == mld_eig_est_) then 
-
-    if (parms%aggr_eig == mld_max_norm_) then 
-      allocate(arwsum(nrow))
-      call acsr%arwsum(arwsum)      
-      anorm = maxval(abs(adiag(1:nrow)*arwsum(1:nrow)))
-      call psb_amx(ictxt,anorm)
-      omega = 4.d0/(3.d0*anorm)
-      parms%aggr_omega_val = omega 
-
-    else 
-      info = psb_err_internal_error_
-      call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
-      goto 9999
-    end if
-
-  else if (parms%aggr_omega_alg == mld_user_choice_) then 
-
-    omega = parms%aggr_omega_val 
-
-  else if (parms%aggr_omega_alg /= mld_user_choice_) then 
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
-    goto 9999
-  end if
-
-  
-  call acsrf%scal(adiag,info)
-  if (info /= psb_success_) goto 9999
-
-  inaggr = naggr
-  call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-  nzlp = coo_prol%get_nzeros()
-  call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-  call coo_prol%set_ncols(tmp_desc%get_local_cols())
-  call coo_prol%mv_to_fmt(csr_prol,info)  
-  !
-  ! Build the smoothed prolongator using either A or Af
-  !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
-  ! This is always done through the variable acsrf which
-  ! is a bit less readable, butsaves space and one extra matrix copy
-  ! 
-  call omega_smooth(omega,acsrf)
-  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,tmp_desc,info)
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done SPSPMM 1'
-  nzl = acsr1%get_nzeros()
-  call acsr1%mv_to_coo(coo_prol,info)
-  
-  call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-       & coo_prol,tmp_desc,coo_restr,info)
-  
-  call op_prol%mv_from(coo_prol)
-  call op_restr%mv_from(coo_restr)
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done smooth_aggregate '
-  call psb_erractionrestore(err_act)
-  return
-
-9999 continue
-  call psb_errpush(info,name)
-  call psb_error_handler(err_act)
-  return
-
-contains
-
-  subroutine omega_smooth(omega,acsr)
-    implicit none 
-    real(psb_spk_),intent(in) :: omega
-    type(psb_lc_csr_sparse_mat), intent(inout) :: acsr
-    !
-    integer(psb_lpk_) :: i,j
-    do i=1,acsr%get_nrows()
-      do j=acsr%irp(i),acsr%irp(i+1)-1
-        if (acsr%ja(j) == i) then 
-          acsr%val(j) = cone - omega*acsr%val(j) 
-        else
-          acsr%val(j) = - omega*acsr%val(j) 
-        end if
-      end do
-    end do
-  end subroutine omega_smooth
-
-end subroutine mld_caggrmat_biz_bld

mlprec/impl/aggregator/mld_caggrmat_minnrg_bld.f90

@@ -104,7 +104,8 @@
 !                  Error code.
 !
 !
-subroutine mld_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_c_inner_mod, mld_protect_name => mld_caggrmat_minnrg_bld
@@ -113,11 +114,12 @@ subroutine mld_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 
   ! Arguments
   type(psb_cspmat_type), intent(in)           :: a
-  type(psb_desc_type), intent(in)               :: desc_a
+  type(psb_desc_type), intent(inout)            :: desc_a
   integer(psb_lpk_), intent(inout)              :: ilaggr(:), nlaggr(:)
   type(mld_sml_parms), intent(inout)         :: parms 
   type(psb_lcspmat_type), intent(inout)       :: op_prol
   type(psb_lcspmat_type), intent(out)         :: ac,op_restr
+  type(psb_desc_type), intent(inout)            :: desc_ac
   integer(psb_ipk_), intent(out)                :: info
 
   ! Local variables

mlprec/impl/aggregator/mld_caggrmat_nosmth_bld.f90

@@ -96,7 +96,8 @@
 !                  Error code.
 !
 !
-subroutine mld_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_c_inner_mod, mld_protect_name => mld_caggrmat_nosmth_bld
@@ -105,26 +106,26 @@ subroutine mld_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 
   ! Arguments
   type(psb_cspmat_type), intent(in)        :: a
-  type(psb_desc_type), intent(in)            :: desc_a
+  type(psb_desc_type), intent(inout)         :: desc_a
   integer(psb_lpk_), intent(inout)           :: ilaggr(:), nlaggr(:)
   type(mld_sml_parms), intent(inout)      :: parms 
-  type(psb_lcspmat_type), intent(inout)    :: op_prol
-  type(psb_lcspmat_type), intent(out)      :: ac,op_restr
+  type(psb_cspmat_type), intent(inout)       :: op_prol,ac,op_restr
+  type(psb_lcspmat_type), intent(inout)    :: t_prol
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)             :: info
 
   ! Local variables
   integer(psb_ipk_)  :: err_act
   integer(psb_ipk_)  :: ictxt, np, me, icomm,  minfo
   character(len=20)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_lcspmat_type)      :: la 
-  type(psb_lc_coo_sparse_mat) :: ac_coo, tmpcoo, coo_prol, coo_restr
-  type(psb_lc_csr_sparse_mat) :: acsr1, acsr2, acsr
-  type(psb_desc_type) :: tmp_desc
+  type(psb_lc_coo_sparse_mat) :: lcoo_prol
+  type(psb_c_coo_sparse_mat) :: coo_prol, coo_restr
+  type(psb_c_csr_sparse_mat) :: acsr
   integer(psb_ipk_) :: debug_level, debug_unit
   integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
        & naggr, nzt, naggrm1, naggrp1, i, k
   integer(psb_ipk_) :: inaggr, nzlp
+  logical, parameter :: debug = .false.
 
   name = 'mld_aggrmat_nosmth_bld'
   info = psb_success_
@@ -145,71 +146,32 @@ subroutine mld_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
   naggrm1 = sum(nlaggr(1:me))
   naggrp1 = sum(nlaggr(1:me+1))
 
-  if (.false.) then
-    !
-    ! If we ever want to switch to explicit product when building this..
-    !
-    call a%cp_to(acsr)
-    call op_prol%mv_to(coo_prol)
-    inaggr = naggr
-    call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-    nzlp = coo_prol%get_nzeros()
-    call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-    call coo_prol%set_ncols(tmp_desc%get_local_cols())
-    call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-         & coo_prol,tmp_desc,coo_restr,info)
+  call a%cp_to(acsr)
+  call t_prol%mv_to(lcoo_prol)
+  inaggr = naggr
+  call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
+  nzlp = lcoo_prol%get_nzeros()
+  call desc_ac%indxmap%g2lip_ins(lcoo_prol%ja(1:nzlp),info) 
+  call lcoo_prol%set_ncols(desc_ac%get_local_cols())
+  call lcoo_prol%cp_to_icoo(coo_prol,info)
+  
+  if (debug) call check_coo(me,trim(name)//' Check 1 on  coo_prol:',coo_prol)
 
-    call op_prol%mv_from(coo_prol)
-    call op_restr%mv_from(coo_restr)
+  call psb_cdasb(desc_ac,info)
+  call psb_cd_reinit(desc_ac,info)
 
+  call mld_ptap(acsr,desc_a,nlaggr,parms,ac,&
+       & coo_prol,desc_ac,coo_restr,info)
 
-  else
-    
-    call a%cp_to(ac_coo)
-    nzt = ac_coo%get_nzeros()
-    k   = 0
-    do i = 1, nzt 
-      k = k + 1 
-      ac_coo%ia(k)  = ilaggr(ac_coo%ia(i))
-      ac_coo%ja(k)  = ilaggr(ac_coo%ja(i))
-      ac_coo%val(k) = ac_coo%val(i)
-      ! At this point, there may be negative entries,
-      ! because that's how ILAGGR marks singletons
-      ! If this is the case, roll back K
-      if ((ac_coo%ia(k)<=0).or.(ac_coo%ja(k)<=0)) k = k-1      
-    enddo
-    call ac_coo%set_nrows(naggr)
-    call ac_coo%set_ncols(naggr)
-    call ac_coo%set_nzeros(k)
-    call ac_coo%set_dupl(psb_dupl_add_)
-    call ac_coo%fix(info)
-    call ac_coo%trim()
-    call ac%mv_from(ac_coo) 
+  call coo_restr%set_nrows(desc_ac%get_local_rows())
+  call coo_restr%set_ncols(desc_a%get_local_cols())
+  call coo_prol%set_nrows(desc_a%get_local_rows())
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
 
-    call op_prol%cp_to(tmpcoo)
+  if (debug) call check_coo(me,trim(name)//' Check 1 on coo_restr:',coo_restr)
 
-    call tmpcoo%transp()
-    !
-    ! Now we have to fix this.  The only rows of tmpcoo/op_restr that are correct 
-    ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-    !
-    nzl = tmpcoo%get_nzeros()
-    i   = 0
-    do k = 1, nzl
-      if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
-        i = i+1
-        tmpcoo%val(i) = tmpcoo%val(k)
-        tmpcoo%ia(i)  = tmpcoo%ia(k)
-        tmpcoo%ja(i)  = tmpcoo%ja(k)
-      end if
-    end do
-    call tmpcoo%set_nzeros(i)
-    call tmpcoo%trim()
-    call op_restr%mv_from(tmpcoo)
-
-    if (info /= psb_success_) goto 9999
-
-  end if
+  call op_prol%mv_from(coo_prol)
+  call op_restr%mv_from(coo_restr)
 
   call psb_erractionrestore(err_act)
   return
@@ -217,5 +179,20 @@ subroutine mld_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 9999 call psb_error_handler(err_act)
 
   return
+  
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_c_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
 
+  end subroutine check_coo
 end subroutine mld_caggrmat_nosmth_bld

mlprec/impl/aggregator/mld_caggrmat_smth_bld.f90

@@ -102,7 +102,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine mld_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_c_inner_mod, mld_protect_name => mld_caggrmat_smth_bld
@@ -112,11 +113,12 @@ subroutine mld_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
 
   ! Arguments
   type(psb_cspmat_type), intent(in)      :: a
-  type(psb_desc_type), intent(in)          :: desc_a
+  type(psb_desc_type), intent(inout)       :: desc_a
   integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
-  type(mld_sml_parms), intent(inout)    :: parms 
-  type(psb_lcspmat_type), intent(inout)  :: op_prol
-  type(psb_lcspmat_type), intent(out)    :: ac,op_restr
+  type(mld_sml_parms), intent(inout)      :: parms 
+  type(psb_cspmat_type), intent(out)      :: op_prol,ac,op_restr
+  type(psb_lcspmat_type), intent(inout)    :: t_prol
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)           :: info
 
   ! Local variables
@@ -125,9 +127,9 @@ subroutine mld_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   integer(psb_ipk_) :: inaggr, nzlp
   integer(psb_ipk_) :: ictxt, np, me
   character(len=20) :: name
-  type(psb_desc_type) :: tmp_desc
-  type(psb_lc_coo_sparse_mat) :: coo_prol, coo_restr, tmpcoo
-  type(psb_lc_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
+  type(psb_lc_coo_sparse_mat) :: tmpcoo
+  type(psb_c_coo_sparse_mat) :: coo_prol, coo_restr
+  type(psb_c_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
   complex(psb_spk_), allocatable :: adiag(:)
   real(psb_spk_), allocatable :: arwsum(:)
   integer(psb_ipk_)  :: ierr(5)
@@ -176,7 +178,6 @@ subroutine mld_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
-  call op_prol%mv_to(coo_prol)
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -255,20 +256,24 @@ subroutine mld_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   call acsrf%scal(adiag,info)
   if (info /= psb_success_) goto 9999
 
+  call t_prol%mv_to(tmpcoo)
   inaggr = naggr
-  call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-  nzlp = coo_prol%get_nzeros()
-  call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-  call coo_prol%set_ncols(tmp_desc%get_local_cols())
-  call coo_prol%mv_to_fmt(csr_prol,info)  
+  call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
+  nzlp = tmpcoo%get_nzeros()
+  call desc_ac%indxmap%g2lip_ins(tmpcoo%ja(1:nzlp),info) 
+  call tmpcoo%set_ncols(desc_ac%get_local_cols())
+  call tmpcoo%mv_to_ifmt(csr_prol,info)
+
+  call psb_cdasb(desc_ac,info)
+  call psb_cd_reinit(desc_ac,info)
   !
   ! Build the smoothed prolongator using either A or Af
   !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
   ! This is always done through the variable acsrf which
-  ! is a bit less readable, butsaves space and one extra matrix copy
+  ! is a bit less readable, but saves space and one matrix copy
   ! 
   call omega_smooth(omega,acsrf)
-  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,tmp_desc,info)
+  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,desc_ac,info)
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
     goto 9999
@@ -281,9 +286,9 @@ subroutine mld_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   nzl = acsr1%get_nzeros()
   call acsr1%mv_to_coo(coo_prol,info)
   
-  call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-       & coo_prol,tmp_desc,coo_restr,info)
-  
+  call mld_ptap(acsr,desc_a,nlaggr,parms,ac,&
+       & coo_prol,desc_ac,coo_restr,info)
+
   call op_prol%mv_from(coo_prol)
   call op_restr%mv_from(coo_restr)
 
@@ -303,7 +308,7 @@ contains
   subroutine omega_smooth(omega,acsr)
     implicit none 
     real(psb_spk_),intent(in) :: omega
-    type(psb_lc_csr_sparse_mat), intent(inout) :: acsr
+    type(psb_c_csr_sparse_mat), intent(inout) :: acsr
     !
     integer(psb_lpk_) :: i,j
     do i=1,acsr%get_nrows()

mlprec/impl/aggregator/mld_d_dec_aggregator_mat_asb.f90

@@ -83,7 +83,7 @@
 !    info       -  integer, output.
 !                  Error code.
 !  
-subroutine  mld_d_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
+subroutine  mld_d_dec_aggregator_mat_asb(ag,parms,a,desc_a,&
      & ac,desc_ac, op_prol,op_restr,info)
   use psb_base_mod
   use mld_base_prec_type
@@ -93,16 +93,13 @@ subroutine  mld_d_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   type(mld_dml_parms), intent(inout)  :: parms 
   type(psb_dspmat_type), intent(in)    :: a
   type(psb_desc_type), intent(inout)     :: desc_a
-  integer(psb_lpk_), intent(inout)       :: ilaggr(:), nlaggr(:)
-  type(psb_ldspmat_type), intent(inout) :: op_prol, ac,op_restr
+  type(psb_dspmat_type), intent(inout) :: op_prol, ac,op_restr
   type(psb_desc_type), intent(inout)     :: desc_ac
   integer(psb_ipk_), intent(out)         :: info
   !
   integer(psb_ipk_)              :: ictxt, np, me
-  type(psb_ld_coo_sparse_mat)  :: lacoo, lbcoo
-  type(psb_d_coo_sparse_mat)   :: acoo
-  type(psb_ld_csr_sparse_mat)  :: acsr1
-  type(psb_dspmat_type)        :: tmp_ac
+  type(psb_ld_coo_sparse_mat)  :: tmpcoo
+  type(psb_ldspmat_type)       :: tmp_ac
   integer(psb_ipk_)              :: i_nr, i_nc, i_nl, nzl
   integer(psb_lpk_)              :: ntaggr
   integer(psb_ipk_) :: err_act, debug_level, debug_unit
@@ -117,70 +114,13 @@ subroutine  mld_d_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   ictxt = desc_a%get_context()
   call psb_info(ictxt,me,np)
 
-
-
-  ntaggr = sum(nlaggr)
-
   select case(parms%coarse_mat)
 
   case(mld_distr_mat_) 
 
-    call ac%mv_to(lbcoo)
-    nzl  = lbcoo%get_nzeros()
-    i_nl = nlaggr(me+1)
-    if (info == psb_success_) call psb_cdall(ictxt,desc_ac,info,nl=i_nl)
-    if (info == psb_success_) call psb_cdins(nzl,lbcoo%ia,lbcoo%ja,desc_ac,info)
-    if (info == psb_success_) call psb_cdasb(desc_ac,info)
-    if (info == psb_success_) call psb_glob_to_loc(lbcoo%ia(1:nzl),desc_ac,info,iact='I')
-    if (info == psb_success_) call psb_glob_to_loc(lbcoo%ja(1:nzl),desc_ac,info,iact='I')
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Creating desc_ac and converting ac')
-      goto 9999
-    end if
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Assembld aux descr. distr.'
-    call ac%mv_from(lbcoo)
-    call ac%set_nrows(desc_ac%get_local_rows())
-    call ac%set_ncols(desc_ac%get_local_cols())
-    call ac%set_asb()
-
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
-      goto 9999
-    end if
-
-    if (np>1) then 
-      call op_prol%mv_to(acsr1)
-      nzl = acsr1%get_nzeros()
-      call psb_glob_to_loc(acsr1%ja(1:nzl),desc_ac,info,'I')
-      if(info /= psb_success_) then
-        call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
-        goto 9999
-      end if
-      call op_prol%mv_from(acsr1)
-    endif
-    call op_prol%set_ncols(desc_ac%get_local_cols())
-
-    if (np>1) then 
-      !call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
-      call op_restr%mv_to(lacoo)
-      nzl = lacoo%get_nzeros()
-      if (info == psb_success_) call psb_glob_to_loc(lacoo%ia(1:nzl),desc_ac,info,'I')
-      call lacoo%set_dupl(psb_dupl_add_)
-      if (info == psb_success_) call op_restr%mv_from(lacoo)
-      if (info == psb_success_) call op_restr%cscnv(info,type='csr')        
-      if(info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Converting op_restr to local')
-        goto 9999
-      end if
-    end if
-    !
-    ! Clip to local rows.
-    !
-    call op_restr%set_nrows(desc_ac%get_local_rows())
+    call ac%cscnv(info,type='csr')
+    call op_prol%cscnv(info,type='csr')
+    call op_restr%cscnv(info,type='csr')
 
     if (debug_level >= psb_debug_outer_) &
          & write(debug_unit,*) me,' ',trim(name),&
@@ -188,23 +128,39 @@ subroutine  mld_d_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
 
   case(mld_repl_mat_) 
     !
+    ! We are assuming here that an d matrix
+    ! can hold all entries
     !
-    ! If we are here, it means we assume that an IPK version of the
-    ! coarse matrix can hold all indices. User beware!
-    !
+    if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
+      ntaggr = desc_ac%get_global_rows()
+      i_nr   = ntaggr
+    else
+      info = psb_err_internal_error_
+      call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
+      goto 9999
+    end if
+    
+    call op_prol%mv_to(tmpcoo)
+    nzl = tmpcoo%get_nzeros()
+    call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
+    call tmpcoo%set_ncols(i_nr)
+    call op_prol%mv_from(tmpcoo)
+
+    call op_restr%mv_to(tmpcoo)
+    nzl = tmpcoo%get_nzeros()
+    call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
+    call tmpcoo%set_nrows(i_nr)
+    call op_restr%mv_from(tmpcoo)
+
+
+    call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
+         & dupl=psb_dupl_add_,keeploc=.false.)
+    call tmp_ac%mv_to(tmpcoo)
+    call ac%mv_from(tmpcoo)
     
-    !
-    ! op_prol/op_restr come from par_spmm_bld with local sizes
-    ! suitable for DIST option, fix relevant sizes
-    ! 
-    call op_prol%set_ncols(ntaggr)
-    call op_restr%set_nrows(ntaggr)
     call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
     if (info == psb_success_) call psb_cdasb(desc_ac,info)
-    if (info == psb_success_) call ac%mv_to(acoo)
-    if (info == psb_success_) call tmp_ac%mv_from(acoo)
-    if (info == psb_success_) &
-         & call psb_gather(ac,tmp_ac,desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)     
+
     if (info /= psb_success_) goto 9999
 
   case default 
@@ -221,4 +177,19 @@ subroutine  mld_d_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   return
 
 
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_ld_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
 end subroutine mld_d_dec_aggregator_mat_asb

mlprec/impl/aggregator/mld_d_dec_aggregator_mat_bld.f90

@@ -133,7 +133,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !  
-subroutine  mld_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_prol,op_restr,info)
+subroutine  mld_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_d_prec_type, mld_protect_name => mld_d_dec_aggregator_mat_bld
   use mld_d_inner_mod 
@@ -144,15 +145,14 @@ subroutine  mld_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_p
   type(psb_dspmat_type), intent(in)    :: a
   type(psb_desc_type), intent(inout)     :: desc_a
   integer(psb_lpk_), intent(inout)     :: ilaggr(:), nlaggr(:)
-  type(psb_ldspmat_type), intent(inout)   :: op_prol
-  type(psb_ldspmat_type), intent(out)   :: ac,op_restr
+  type(psb_ldspmat_type), intent(inout)   :: t_prol
+  type(psb_dspmat_type), intent(out)   :: op_prol,ac,op_restr
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)       :: info
 
   ! Local variables
   character(len=20)            :: name
   integer(psb_mpk_)            :: ictxt, np, me
-  type(psb_ld_coo_sparse_mat) :: acoo, bcoo
-  type(psb_ld_csr_sparse_mat) :: acsr1
   integer(psb_lpk_)            :: nzl,ntaggr
   integer(psb_ipk_)            :: err_act
   integer(psb_ipk_)            :: debug_level, debug_unit
@@ -177,22 +177,22 @@ subroutine  mld_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_p
   case (mld_no_smooth_) 
 
     call mld_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,&
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case(mld_smooth_prol_) 
 
     call mld_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
-  case(mld_biz_prol_) 
-
-    call mld_daggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+!!$  case(mld_biz_prol_) 
+!!$
+!!$    call mld_daggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
+!!$         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case(mld_min_energy_) 
 
     call mld_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case default
     info = psb_err_internal_error_

mlprec/impl/aggregator/mld_d_dec_aggregator_tprol.f90

@@ -68,14 +68,14 @@
 !                  overlap.
 !    nlaggr     -  integer, dimension(:), allocatable, output
 !                  nlaggr(i) contains the aggregates held by process i.
-!    op_prol    -  type(psb_dspmat_type), output
+!    t_prol    -  type(psb_dspmat_type), output
 !               The tentative prolongator, based on ilaggr.
 !               
 !    info    -  integer, output.
 !               Error code.         
 !  
 subroutine  mld_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
-     & a,desc_a,ilaggr,nlaggr,op_prol,info)
+     & a,desc_a,ilaggr,nlaggr,t_prol,info)
   use psb_base_mod
   use mld_d_prec_type, mld_protect_name => mld_d_dec_aggregator_build_tprol
   use mld_d_inner_mod
@@ -86,7 +86,7 @@ subroutine  mld_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
   type(psb_dspmat_type), intent(in)   :: a
   type(psb_desc_type), intent(in)     :: desc_a
   integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
-  type(psb_ldspmat_type), intent(out)  :: op_prol
+  type(psb_ldspmat_type), intent(out)  :: t_prol
   integer(psb_ipk_), intent(out)      :: info
 
   ! Local variables
@@ -123,7 +123,7 @@ subroutine  mld_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
   clean_zeros = ag%do_clean_zeros
   call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
 
-  if (info==psb_success_) call mld_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
+  if (info==psb_success_) call mld_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

mlprec/impl/aggregator/mld_d_map_to_tprol.f90

@@ -124,9 +124,9 @@ subroutine mld_d_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
     goto 9999
   end if
 
-  call tmpcoo%allocate(ncol,ntaggr,ncol)
+  call tmpcoo%allocate(nrow,ntaggr,ncol)
   k = 0 
-  do i=1,ncol
+  do i=1,nrow
     !
     ! Note: at this point, a value ilaggr(i)<=0
     ! tags a "singleton" row, and it has to be

mlprec/impl/aggregator/mld_d_ptap.f90

@@ -0,0 +1,689 @@
+!   
+!   
+!                             MLD2P4  Extensions
+!    
+!    (C) Copyright 2019
+!  
+!                        Salvatore Filippone  Cranfield University
+!        Pasqua D'Ambra         IAC-CNR, Naples, IT
+!   
+!    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.
+!   
+!  
+! File: mld_daggrmat_nosmth_bld.F90
+!
+!
+subroutine mld_d_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_d_inner_mod
+  use mld_d_base_aggregator_mod, mld_protect_name => mld_d_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_d_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)          :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_dml_parms), intent(inout)         :: parms 
+  type(psb_d_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_dspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_ld_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_d_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nglob, ntaggr, naggrm1, naggrp1
+  integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_fmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      call coo_prol%cp_to_coo(coo_restr,info)
+      call coo_restr%set_ncols(desc_ac%get_local_cols())
+      call coo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_d_coo_glob_transpose(coo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call coo_restr%set_nrows(desc_ac%get_local_rows())
+      call coo_restr%set_ncols(desc_ax%get_local_cols())
+!!$      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+!!$           & desc_a%get_local_cols(),desc_ax%get_local_cols(),coo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+    end block
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_coo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_d_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_d_ptap
+
+subroutine mld_d_ld_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_d_inner_mod
+  use mld_d_base_aggregator_mod !, mld_protect_name => mld_d_ld_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_d_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)          :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_dml_parms), intent(inout)         :: parms 
+  type(psb_ld_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_ldspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_ld_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_d_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
+       &  nzt, naggrm1, naggrp1, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_ifmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      type(psb_d_coo_sparse_mat) :: icoo_restr
+
+      call coo_prol%cp_to_icoo(icoo_restr,info)
+      call icoo_restr%set_ncols(desc_ac%get_local_cols())
+      call icoo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_d_coo_glob_transpose(icoo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call icoo_restr%set_nrows(desc_ac%get_local_rows())
+      call icoo_restr%set_ncols(desc_ax%get_local_cols())
+      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+           & desc_a%get_local_cols(),desc_ax%get_local_cols(),icoo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+      call coo_restr%cp_from_icoo(icoo_restr,info)
+    end block
+    call csr_restr%cp_from_lcoo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_lcoo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_lcoo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_ld_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_d_ld_ptap
+
+subroutine mld_ld_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_d_inner_mod
+  use mld_d_base_aggregator_mod!, mld_protect_name => mld_ld_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_ld_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)           :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_dml_parms), intent(inout)         :: parms 
+  type(psb_ld_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_ldspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_ld_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_ld_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
+       &  nzt, naggrm1, naggrp1, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_fmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      type(psb_d_coo_sparse_mat) :: icoo_restr
+
+      call coo_prol%cp_to_icoo(icoo_restr,info)
+      call icoo_restr%set_ncols(desc_ac%get_local_cols())
+      call icoo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_d_coo_glob_transpose(icoo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call icoo_restr%set_nrows(desc_ac%get_local_rows())
+      call icoo_restr%set_ncols(desc_ax%get_local_cols())
+      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+           & desc_a%get_local_cols(),desc_ax%get_local_cols(),icoo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+      call coo_restr%cp_from_icoo(icoo_restr,info)
+    end block
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_coo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  !call coo_restr%mv_from_ifmt(csr_restr,info)
+!!$    call coo_restr%set_nrows(desc_ac%get_local_rows())
+!!$    call coo_restr%set_ncols(desc_a%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_ld_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_ld_ptap

mlprec/impl/aggregator/mld_d_spmm_bld_inner.f90

@@ -1,390 +0,0 @@
-!   
-!   
-!                             MLD2P4  Extensions
-!    
-!    (C) Copyright 2019
-!  
-!                        Salvatore Filippone  Cranfield University
-!        Pasqua D'Ambra         IAC-CNR, Naples, IT
-!   
-!    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.
-!   
-!  
-! File: mld_daggrmat_nosmth_bld.F90
-!
-!
-subroutine mld_d_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,&
-     & coo_prol,desc_cprol,coo_restr,info)
-  use psb_base_mod
-  use mld_d_inner_mod
-  use mld_d_base_aggregator_mod, mld_protect_name => mld_d_spmm_bld_inner
-  implicit none
-
-  ! Arguments
-  type(psb_d_csr_sparse_mat), intent(inout) :: a_csr
-  type(psb_desc_type), intent(in)            :: desc_a
-  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
-  type(mld_dml_parms), intent(inout)         :: parms 
-  type(psb_ld_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
-  type(psb_desc_type), intent(inout)         :: desc_cprol
-  type(psb_ldspmat_type), intent(out)        :: ac
-  integer(psb_ipk_), intent(out)             :: info
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
-  character(len=40)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_ld_coo_sparse_mat) :: ac_coo, tmpcoo
-  type(psb_d_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
-  integer(psb_ipk_) :: debug_level, debug_unit, naggr
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
-       &  nzt, naggrm1, naggrp1, i, k
-  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
-  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
-
-  name='mld_spmm_bld_inner'
-  if(psb_get_errstatus().ne.0) return 
-  info=psb_success_
-  call psb_erractionsave(err_act)
-
-
-  ictxt = desc_a%get_context()
-  icomm = desc_a%get_mpic()
-  call psb_info(ictxt, me, np)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
-
-  naggr   = nlaggr(me+1)
-  ntaggr  = sum(nlaggr)
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1)) 
-  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
-
-  !
-  ! COO_PROL should arrive here with local numbering
-  !
-  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
-       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
-       & nrow,ntaggr,naggr
-
-  call coo_prol%cp_to_ifmt(csr_prol,info)
-
-  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
-       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
-       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols()
-  if (debug) flush(0)
-
-  if (do_timings) call psb_tic(idx_spspmm)
-  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)  
-
-  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
-       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
-       & desc_cprol%get_local_rows(),desc_cprol%get_local_cols()
-
-  !
-  ! Ok first product done.
-  !
-  ! Remember that RESTR must be built from PROL after halo extension,
-  ! which is done above in psb_par_spspmm
-  if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
-       & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
-  call csr_prol%cp_to_lcoo(coo_restr,info)
-!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
-!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
-  call coo_restr%transp()
-  nzl = coo_restr%get_nzeros()
-  call desc_cprol%l2gip(coo_restr%ia(1:nzl),info)
-  i=0
-  !
-  ! Now we have to fix this.  The only rows of the restrictor that are correct 
-  ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-  !
-  do k=1, nzl
-    if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then
-      i = i+1
-      coo_restr%val(i) = coo_restr%val(k)
-      coo_restr%ia(i)  = coo_restr%ia(k)
-      coo_restr%ja(i)  = coo_restr%ja(k)
-    end if
-  end do
-  call coo_restr%set_nzeros(i)
-  call coo_restr%fix(info)
-  call coo_restr%cp_to_coo(tmpcoo,info)
-!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
-
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
-    goto 9999
-  end if
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'starting sphalo/ rwxtd'
-  nzl    = tmpcoo%get_nzeros()    
-  call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_cprol,info,iact='I',owned=.true.)
-  call tmpcoo%clean_negidx(info)
-  nzl  = tmpcoo%get_nzeros()
-  call tmpcoo%set_nrows(desc_cprol%get_local_rows())
-  call tmpcoo%set_ncols(desc_a%get_local_cols())
-!!$    write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros()      
-  call csr_restr%mv_from_lcoo(tmpcoo,info)
-
-  if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
-       & csr_restr%get_nrows(),csr_restr%get_ncols(), &
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols(),&
-       & acsr3%get_nrows(),acsr3%get_ncols()
-  if (do_timings) call psb_tic(idx_spspmm)      
-  call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)      
-  call csr_restr%free()
-  call acsr3%free()
-  call ac_csr%mv_to_lcoo(ac_coo,info)
-  call ac_coo%fix(info)
-  nza    = ac_coo%get_nzeros()
-  if (debug) write(0,*) me,trim(name),' Fixed ac ',&
-       & ac_coo%get_nrows(),ac_coo%get_ncols(), nza
-  call desc_cprol%indxmap%l2gip(ac_coo%ia(1:nza),info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ja(1:nza),info)
-  call ac_coo%set_nrows(ntaggr)
-  call ac_coo%set_ncols(ntaggr)
-  if (debug) write(0,*)  me,' ',trim(name),' Before mv_from',psb_get_errstatus()
-  if (info == 0) call ac%mv_from(ac_coo)
-  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
-  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
-  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
-
-  nza = coo_prol%get_nzeros()
-  call desc_cprol%indxmap%l2gip(coo_prol%ja(1:nza),info)
-  
-  if (debug) then
-    write(0,*) me,' ',trim(name),' Checkpoint at exit'
-    call psb_barrier(ictxt)
-    write(0,*) me,' ',trim(name),' Checkpoint through'
-  end if
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done spmm_bld_inner '
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-  
-end subroutine mld_d_spmm_bld_inner
-
-subroutine mld_ld_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,&
-     & coo_prol,desc_cprol,coo_restr,info)
-  use psb_base_mod
-  use mld_d_inner_mod
-  use mld_d_base_aggregator_mod, mld_protect_name => mld_ld_spmm_bld_inner
-  implicit none
-
-  ! Arguments
-  type(psb_ld_csr_sparse_mat), intent(inout) :: a_csr
-  type(psb_desc_type), intent(in)            :: desc_a
-  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
-  type(mld_dml_parms), intent(inout)         :: parms 
-  type(psb_ld_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
-  type(psb_desc_type), intent(inout)         :: desc_cprol
-  type(psb_ldspmat_type), intent(out)        :: ac
-  integer(psb_ipk_), intent(out)             :: info
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
-  character(len=40)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_ld_coo_sparse_mat) :: ac_coo, tmpcoo
-  type(psb_ld_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
-  integer(psb_ipk_) :: debug_level, debug_unit, naggr
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
-       &  nzt, naggrm1, naggrp1, i, k
-  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
-  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
-
-  name='mld_spmm_bld_inner'
-  if(psb_get_errstatus().ne.0) return 
-  info=psb_success_
-  call psb_erractionsave(err_act)
-
-
-  ictxt = desc_a%get_context()
-  icomm = desc_a%get_mpic()
-  call psb_info(ictxt, me, np)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
-
-  naggr   = nlaggr(me+1)
-  ntaggr  = sum(nlaggr)
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1)) 
-  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
-
-  !
-  ! Here COO_PROL should be with GLOBAL indices on the cols
-  ! and LOCAL indices on the rows. 
-  !
-  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
-       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
-       & nrow,ntaggr,naggr
-
-  call coo_prol%cp_to_fmt(csr_prol,info)
-
-  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
-       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
-       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols()
-  if (debug) flush(0)
-
-  if (do_timings) call psb_tic(idx_spspmm)
-  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)  
-
-  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
-       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
-       & desc_cprol%get_local_rows(),desc_cprol%get_local_cols()
-
-  !
-  ! Ok first product done.
-  !
-  ! Remember that RESTR must be built from PROL after halo extension,
-  ! which is done above in psb_par_spspmm
-  if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
-       & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
-  call csr_prol%cp_to_fmt(coo_restr,info)
-!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
-!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
-  call coo_restr%transp()
-  nzl = coo_restr%get_nzeros()
-  call desc_cprol%l2gip(coo_restr%ia(1:nzl),info)
-  i=0
-  !
-  ! Now we have to fix this.  The only rows of the restrictor that are correct 
-  ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-  !
-  do k=1, nzl
-    if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then
-      i = i+1
-      coo_restr%val(i) = coo_restr%val(k)
-      coo_restr%ia(i)  = coo_restr%ia(k)
-      coo_restr%ja(i)  = coo_restr%ja(k)
-    end if
-  end do
-  call coo_restr%set_nzeros(i)
-  call coo_restr%fix(info)
-  call coo_restr%cp_to_coo(tmpcoo,info)
-!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
-
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
-    goto 9999
-  end if
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'starting sphalo/ rwxtd'
-  nzl    = tmpcoo%get_nzeros()    
-  call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_cprol,info,iact='I',owned=.true.)
-  call tmpcoo%clean_negidx(info)
-  nzl  = tmpcoo%get_nzeros()
-  call tmpcoo%set_nrows(desc_cprol%get_local_rows())
-  call tmpcoo%set_ncols(desc_a%get_local_cols())
-!!$    write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros()      
-  call csr_restr%mv_from_coo(tmpcoo,info)
-
-  if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
-       & csr_restr%get_nrows(),csr_restr%get_ncols(), &
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols(),&
-       & acsr3%get_nrows(),acsr3%get_ncols()
-  if (do_timings) call psb_tic(idx_spspmm)      
-  call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)      
-  call csr_restr%free()
-  call ac_csr%mv_to_coo(ac_coo,info)
-  nza    = ac_coo%get_nzeros()
-  if (debug) write(0,*) me,trim(name),' Fixing ac ',&
-       & ac_coo%get_nrows(),ac_coo%get_ncols(), nza
-  call ac_coo%fix(info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ia(1:nza),info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ja(1:nza),info)
-  call ac_coo%set_nrows(ntaggr)
-  call ac_coo%set_ncols(ntaggr)
-  if (debug) write(0,*)  me,' ',trim(name),' Before mv_from',psb_get_errstatus()
-  if (info == 0) call ac%mv_from(ac_coo)
-  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
-  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
-  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
-
-  nza = coo_prol%get_nzeros()
-  call desc_cprol%indxmap%l2gip(coo_prol%ja(1:nza),info)
-  
-  if (debug) then
-    write(0,*) me,' ',trim(name),' Checkpoint at exit'
-    call psb_barrier(ictxt)
-    write(0,*) me,' ',trim(name),' Checkpoint through'
-  end if
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done spmm_bld_inner '
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-  
-end subroutine mld_ld_spmm_bld_inner

mlprec/impl/aggregator/mld_daggrmat_biz_bld.f90

@@ -1,300 +0,0 @@
-!   
-!   
-!                             MLD2P4  version 2.2
-!    MultiLevel Domain Decomposition Parallel Preconditioners Package
-!               based on PSBLAS (Parallel Sparse BLAS version 3.5)
-!    
-!    (C) Copyright 2008-2018 
-!  
-!        Salvatore Filippone  
-!        Pasqua D'Ambra   
-!        Daniela di Serafino   
-!   
-!    Redistribution and use in source and binary forms, with or without
-!    modification, are permitted provided that the following conditions
-!    are met:
-!      1. Redistributions of source code must retain the above copyright
-!         notice, this list of conditions and the following disclaimer.
-!      2. Redistributions in binary form must reproduce the above copyright
-!         notice, this list of conditions, and the following disclaimer in the
-!         documentation and/or other materials provided with the distribution.
-!      3. The name of the 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.
-!   
-!  
-! File: mld_daggrmat_biz_bld.F90
-!
-! Subroutine: mld_daggrmat_biz_bld
-! Version:    real
-!
-!  This routine builds a coarse-level matrix A_C from a fine-level matrix A
-!  by using the Galerkin approach, i.e.
-!
-!                               A_C = P_C^T A P_C,
-!
-!  where P_C is a prolongator from the coarse level to the fine one.
-! 
-!  This routine builds A_C according to a "bizarre" aggregation algorithm,
-!  using a "naive" prolongator proposed by the authors of MLD2P4. However, this
-!  prolongator still requires additional analysis and testing and its use is not
-!  recommended.
-!
-!  The coarse-level matrix A_C is distributed among the parallel processes or
-!  replicated on each of them, according to the value of p%parms%coarse_mat,
-!  specified by the user through mld_dprecinit and mld_zprecset.
-!  On output from this routine the entries of AC, op_prol, op_restr
-!  are still in "global numbering" mode; this is fixed in the calling routine
-!  mld_d_lev_aggrmat_bld.
-!
-! Arguments:
-!    a          -  type(psb_dspmat_type), input.     
-!                  The sparse matrix structure containing the local part of
-!                  the fine-level matrix.
-!    desc_a     -  type(psb_desc_type), input.
-!                  The communication descriptor of the fine-level matrix.
-!    p          -  type(mld_d_onelev_type), input/output.
-!                  The 'one-level' data structure that will contain the local
-!                  part of the matrix to be built as well as the information 
-!                  concerning the prolongator and its transpose.
-!    ilaggr     -  integer, dimension(:), allocatable.
-!                  The mapping between the row indices of the coarse-level
-!                  matrix and the row indices of the fine-level matrix.
-!                  ilaggr(i)=j means that node i in the adjacency graph
-!                  of the fine-level matrix is mapped onto node j in the
-!                  adjacency graph of the coarse-level matrix.
-!    nlaggr     -  integer, dimension(:), allocatable.
-!                  nlaggr(i) contains the aggregates held by process i.
-!    info       -  integer, output.
-!                  Error code.
-!
-subroutine mld_daggrmat_biz_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
-  use psb_base_mod
-  use mld_base_prec_type
-  use mld_d_inner_mod, mld_protect_name => mld_daggrmat_biz_bld
-  use mld_d_base_aggregator_mod
-  
-  implicit none
-
-  ! Arguments
-  type(psb_dspmat_type), intent(in)      :: a
-  type(psb_desc_type), intent(in)          :: desc_a
-  integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
-  type(mld_dml_parms), intent(inout)    :: parms 
-  type(psb_ldspmat_type), intent(inout)  :: op_prol
-  type(psb_ldspmat_type), intent(out)    :: ac,op_restr
-  integer(psb_ipk_), intent(out)           :: info
-
-  ! Local variables
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
-       & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
-  integer(psb_ipk_) :: inaggr, nzlp, inrow
-  integer(psb_ipk_) :: ictxt, np, me
-  character(len=20) :: name
-  type(psb_desc_type) :: tmp_desc
-  type(psb_d_coo_sparse_mat)  :: icoo
-  type(psb_ld_coo_sparse_mat) :: coo_prol, coo_restr, tmpcoo
-  type(psb_ld_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
-  real(psb_dpk_), allocatable :: adiag(:)
-  real(psb_dpk_), allocatable :: arwsum(:)
-  integer(psb_ipk_)  :: ierr(5)
-  logical            :: filter_mat
-  integer(psb_ipk_)            :: debug_level, debug_unit, err_act
-  integer(psb_ipk_), parameter :: ncmax=16
-  real(psb_dpk_)     :: anorm, omega, tmp, dg, theta
-  logical, parameter :: debug_new=.false.
-  character(len=80) :: filename
-
-  name='mld_aggrmat_biz_bld'
-  info=psb_success_
-  call psb_erractionsave(err_act)
-  if (psb_errstatus_fatal()) then
-    info = psb_err_internal_error_; goto 9999
-  end if
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-
-  ictxt = desc_a%get_context()
-
-  call psb_info(ictxt, me, np)
-
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  theta = parms%aggr_thresh
-
-  naggr  = nlaggr(me+1)
-  ntaggr = sum(nlaggr)
-
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1))
-  filter_mat = (parms%aggr_filter == mld_filter_mat_)
-
-  !
-  ! naggr: number of local aggregates
-  ! nrow: local rows. 
-  ! 
-
-  ! Get the diagonal D
-  adiag = a%get_diag(info)
-  if (info == psb_success_) &
-       & call psb_realloc(ncol,adiag,info)
-  if (info == psb_success_) &
-       & call psb_halo(adiag,desc_a,info)
-  if (info == psb_success_) call a%csclip(icoo,info,jmax=a%get_nrows())
-  call icoo%mv_to_lfmt(acsr,info)
-  call op_prol%mv_to(coo_prol)
-
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
-    goto 9999
-  end if
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & ' Initial copies done.'
-
-  call acsr%cp_to_fmt(acsrf,info)
-
-
-  if (filter_mat) then
-    !
-    ! Build the filtered matrix Af from A
-    ! 
-
-    do i=1, nrow
-      tmp = dzero
-      jd  = -1 
-      do j=acsrf%irp(i),acsrf%irp(i+1)-1
-        if (acsrf%ja(j) == i) jd = j 
-        if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
-          tmp=tmp+acsrf%val(j)
-          acsrf%val(j)=dzero
-        endif
-
-      enddo
-      if (jd == -1) then 
-        write(0,*) 'Wrong input: we need the diagonal!!!!', i
-      else
-        acsrf%val(jd)=acsrf%val(jd)-tmp
-      end if
-    enddo
-    ! Take out zeroed terms 
-    call acsrf%clean_zeros(info)
-  end if
-
-
-  do i=1,size(adiag)
-    if (adiag(i) /= dzero) then
-      adiag(i) = done / adiag(i)
-    else
-      adiag(i) = done
-    end if
-  end do
-
-  if (parms%aggr_omega_alg == mld_eig_est_) then 
-
-    if (parms%aggr_eig == mld_max_norm_) then 
-      allocate(arwsum(nrow))
-      call acsr%arwsum(arwsum)      
-      anorm = maxval(abs(adiag(1:nrow)*arwsum(1:nrow)))
-      call psb_amx(ictxt,anorm)
-      omega = 4.d0/(3.d0*anorm)
-      parms%aggr_omega_val = omega 
-
-    else 
-      info = psb_err_internal_error_
-      call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
-      goto 9999
-    end if
-
-  else if (parms%aggr_omega_alg == mld_user_choice_) then 
-
-    omega = parms%aggr_omega_val 
-
-  else if (parms%aggr_omega_alg /= mld_user_choice_) then 
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
-    goto 9999
-  end if
-
-  
-  call acsrf%scal(adiag,info)
-  if (info /= psb_success_) goto 9999
-
-  inaggr = naggr
-  call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-  nzlp = coo_prol%get_nzeros()
-  call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-  call coo_prol%set_ncols(tmp_desc%get_local_cols())
-  call coo_prol%mv_to_fmt(csr_prol,info)  
-  !
-  ! Build the smoothed prolongator using either A or Af
-  !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
-  ! This is always done through the variable acsrf which
-  ! is a bit less readable, butsaves space and one extra matrix copy
-  ! 
-  call omega_smooth(omega,acsrf)
-  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,tmp_desc,info)
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done SPSPMM 1'
-  nzl = acsr1%get_nzeros()
-  call acsr1%mv_to_coo(coo_prol,info)
-  
-  call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-       & coo_prol,tmp_desc,coo_restr,info)
-  
-  call op_prol%mv_from(coo_prol)
-  call op_restr%mv_from(coo_restr)
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done smooth_aggregate '
-  call psb_erractionrestore(err_act)
-  return
-
-9999 continue
-  call psb_errpush(info,name)
-  call psb_error_handler(err_act)
-  return
-
-contains
-
-  subroutine omega_smooth(omega,acsr)
-    implicit none 
-    real(psb_dpk_),intent(in) :: omega
-    type(psb_ld_csr_sparse_mat), intent(inout) :: acsr
-    !
-    integer(psb_lpk_) :: i,j
-    do i=1,acsr%get_nrows()
-      do j=acsr%irp(i),acsr%irp(i+1)-1
-        if (acsr%ja(j) == i) then 
-          acsr%val(j) = done - omega*acsr%val(j) 
-        else
-          acsr%val(j) = - omega*acsr%val(j) 
-        end if
-      end do
-    end do
-  end subroutine omega_smooth
-
-end subroutine mld_daggrmat_biz_bld

mlprec/impl/aggregator/mld_daggrmat_minnrg_bld.f90

@@ -104,7 +104,8 @@
 !                  Error code.
 !
 !
-subroutine mld_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_d_inner_mod, mld_protect_name => mld_daggrmat_minnrg_bld
@@ -113,11 +114,12 @@ subroutine mld_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 
   ! Arguments
   type(psb_dspmat_type), intent(in)           :: a
-  type(psb_desc_type), intent(in)               :: desc_a
+  type(psb_desc_type), intent(inout)            :: desc_a
   integer(psb_lpk_), intent(inout)              :: ilaggr(:), nlaggr(:)
   type(mld_dml_parms), intent(inout)         :: parms 
   type(psb_ldspmat_type), intent(inout)       :: op_prol
   type(psb_ldspmat_type), intent(out)         :: ac,op_restr
+  type(psb_desc_type), intent(inout)            :: desc_ac
   integer(psb_ipk_), intent(out)                :: info
 
   ! Local variables

mlprec/impl/aggregator/mld_daggrmat_nosmth_bld.f90

@@ -96,7 +96,8 @@
 !                  Error code.
 !
 !
-subroutine mld_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_d_inner_mod, mld_protect_name => mld_daggrmat_nosmth_bld
@@ -105,26 +106,26 @@ subroutine mld_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 
   ! Arguments
   type(psb_dspmat_type), intent(in)        :: a
-  type(psb_desc_type), intent(in)            :: desc_a
+  type(psb_desc_type), intent(inout)         :: desc_a
   integer(psb_lpk_), intent(inout)           :: ilaggr(:), nlaggr(:)
   type(mld_dml_parms), intent(inout)      :: parms 
-  type(psb_ldspmat_type), intent(inout)    :: op_prol
-  type(psb_ldspmat_type), intent(out)      :: ac,op_restr
+  type(psb_dspmat_type), intent(inout)       :: op_prol,ac,op_restr
+  type(psb_ldspmat_type), intent(inout)    :: t_prol
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)             :: info
 
   ! Local variables
   integer(psb_ipk_)  :: err_act
   integer(psb_ipk_)  :: ictxt, np, me, icomm,  minfo
   character(len=20)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_ldspmat_type)      :: la 
-  type(psb_ld_coo_sparse_mat) :: ac_coo, tmpcoo, coo_prol, coo_restr
-  type(psb_ld_csr_sparse_mat) :: acsr1, acsr2, acsr
-  type(psb_desc_type) :: tmp_desc
+  type(psb_ld_coo_sparse_mat) :: lcoo_prol
+  type(psb_d_coo_sparse_mat) :: coo_prol, coo_restr
+  type(psb_d_csr_sparse_mat) :: acsr
   integer(psb_ipk_) :: debug_level, debug_unit
   integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
        & naggr, nzt, naggrm1, naggrp1, i, k
   integer(psb_ipk_) :: inaggr, nzlp
+  logical, parameter :: debug = .false.
 
   name = 'mld_aggrmat_nosmth_bld'
   info = psb_success_
@@ -145,71 +146,32 @@ subroutine mld_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
   naggrm1 = sum(nlaggr(1:me))
   naggrp1 = sum(nlaggr(1:me+1))
 
-  if (.false.) then
-    !
-    ! If we ever want to switch to explicit product when building this..
-    !
-    call a%cp_to(acsr)
-    call op_prol%mv_to(coo_prol)
-    inaggr = naggr
-    call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-    nzlp = coo_prol%get_nzeros()
-    call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-    call coo_prol%set_ncols(tmp_desc%get_local_cols())
-    call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-         & coo_prol,tmp_desc,coo_restr,info)
+  call a%cp_to(acsr)
+  call t_prol%mv_to(lcoo_prol)
+  inaggr = naggr
+  call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
+  nzlp = lcoo_prol%get_nzeros()
+  call desc_ac%indxmap%g2lip_ins(lcoo_prol%ja(1:nzlp),info) 
+  call lcoo_prol%set_ncols(desc_ac%get_local_cols())
+  call lcoo_prol%cp_to_icoo(coo_prol,info)
+  
+  if (debug) call check_coo(me,trim(name)//' Check 1 on  coo_prol:',coo_prol)
 
-    call op_prol%mv_from(coo_prol)
-    call op_restr%mv_from(coo_restr)
+  call psb_cdasb(desc_ac,info)
+  call psb_cd_reinit(desc_ac,info)
 
+  call mld_ptap(acsr,desc_a,nlaggr,parms,ac,&
+       & coo_prol,desc_ac,coo_restr,info)
 
-  else
-    
-    call a%cp_to(ac_coo)
-    nzt = ac_coo%get_nzeros()
-    k   = 0
-    do i = 1, nzt 
-      k = k + 1 
-      ac_coo%ia(k)  = ilaggr(ac_coo%ia(i))
-      ac_coo%ja(k)  = ilaggr(ac_coo%ja(i))
-      ac_coo%val(k) = ac_coo%val(i)
-      ! At this point, there may be negative entries,
-      ! because that's how ILAGGR marks singletons
-      ! If this is the case, roll back K
-      if ((ac_coo%ia(k)<=0).or.(ac_coo%ja(k)<=0)) k = k-1      
-    enddo
-    call ac_coo%set_nrows(naggr)
-    call ac_coo%set_ncols(naggr)
-    call ac_coo%set_nzeros(k)
-    call ac_coo%set_dupl(psb_dupl_add_)
-    call ac_coo%fix(info)
-    call ac_coo%trim()
-    call ac%mv_from(ac_coo) 
+  call coo_restr%set_nrows(desc_ac%get_local_rows())
+  call coo_restr%set_ncols(desc_a%get_local_cols())
+  call coo_prol%set_nrows(desc_a%get_local_rows())
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
 
-    call op_prol%cp_to(tmpcoo)
+  if (debug) call check_coo(me,trim(name)//' Check 1 on coo_restr:',coo_restr)
 
-    call tmpcoo%transp()
-    !
-    ! Now we have to fix this.  The only rows of tmpcoo/op_restr that are correct 
-    ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-    !
-    nzl = tmpcoo%get_nzeros()
-    i   = 0
-    do k = 1, nzl
-      if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
-        i = i+1
-        tmpcoo%val(i) = tmpcoo%val(k)
-        tmpcoo%ia(i)  = tmpcoo%ia(k)
-        tmpcoo%ja(i)  = tmpcoo%ja(k)
-      end if
-    end do
-    call tmpcoo%set_nzeros(i)
-    call tmpcoo%trim()
-    call op_restr%mv_from(tmpcoo)
-
-    if (info /= psb_success_) goto 9999
-
-  end if
+  call op_prol%mv_from(coo_prol)
+  call op_restr%mv_from(coo_restr)
 
   call psb_erractionrestore(err_act)
   return
@@ -217,5 +179,20 @@ subroutine mld_daggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 9999 call psb_error_handler(err_act)
 
   return
+  
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_d_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
 
+  end subroutine check_coo
 end subroutine mld_daggrmat_nosmth_bld

mlprec/impl/aggregator/mld_daggrmat_smth_bld.f90

@@ -102,7 +102,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine mld_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_d_inner_mod, mld_protect_name => mld_daggrmat_smth_bld
@@ -112,11 +113,12 @@ subroutine mld_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
 
   ! Arguments
   type(psb_dspmat_type), intent(in)      :: a
-  type(psb_desc_type), intent(in)          :: desc_a
+  type(psb_desc_type), intent(inout)       :: desc_a
   integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
-  type(mld_dml_parms), intent(inout)    :: parms 
-  type(psb_ldspmat_type), intent(inout)  :: op_prol
-  type(psb_ldspmat_type), intent(out)    :: ac,op_restr
+  type(mld_dml_parms), intent(inout)      :: parms 
+  type(psb_dspmat_type), intent(out)      :: op_prol,ac,op_restr
+  type(psb_ldspmat_type), intent(inout)    :: t_prol
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)           :: info
 
   ! Local variables
@@ -125,9 +127,9 @@ subroutine mld_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   integer(psb_ipk_) :: inaggr, nzlp
   integer(psb_ipk_) :: ictxt, np, me
   character(len=20) :: name
-  type(psb_desc_type) :: tmp_desc
-  type(psb_ld_coo_sparse_mat) :: coo_prol, coo_restr, tmpcoo
-  type(psb_ld_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
+  type(psb_ld_coo_sparse_mat) :: tmpcoo
+  type(psb_d_coo_sparse_mat) :: coo_prol, coo_restr
+  type(psb_d_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
   real(psb_dpk_), allocatable :: adiag(:)
   real(psb_dpk_), allocatable :: arwsum(:)
   integer(psb_ipk_)  :: ierr(5)
@@ -176,7 +178,6 @@ subroutine mld_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
-  call op_prol%mv_to(coo_prol)
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -255,20 +256,24 @@ subroutine mld_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   call acsrf%scal(adiag,info)
   if (info /= psb_success_) goto 9999
 
+  call t_prol%mv_to(tmpcoo)
   inaggr = naggr
-  call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-  nzlp = coo_prol%get_nzeros()
-  call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-  call coo_prol%set_ncols(tmp_desc%get_local_cols())
-  call coo_prol%mv_to_fmt(csr_prol,info)  
+  call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
+  nzlp = tmpcoo%get_nzeros()
+  call desc_ac%indxmap%g2lip_ins(tmpcoo%ja(1:nzlp),info) 
+  call tmpcoo%set_ncols(desc_ac%get_local_cols())
+  call tmpcoo%mv_to_ifmt(csr_prol,info)
+
+  call psb_cdasb(desc_ac,info)
+  call psb_cd_reinit(desc_ac,info)
   !
   ! Build the smoothed prolongator using either A or Af
   !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
   ! This is always done through the variable acsrf which
-  ! is a bit less readable, butsaves space and one extra matrix copy
+  ! is a bit less readable, but saves space and one matrix copy
   ! 
   call omega_smooth(omega,acsrf)
-  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,tmp_desc,info)
+  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,desc_ac,info)
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
     goto 9999
@@ -281,9 +286,9 @@ subroutine mld_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   nzl = acsr1%get_nzeros()
   call acsr1%mv_to_coo(coo_prol,info)
   
-  call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-       & coo_prol,tmp_desc,coo_restr,info)
-  
+  call mld_ptap(acsr,desc_a,nlaggr,parms,ac,&
+       & coo_prol,desc_ac,coo_restr,info)
+
   call op_prol%mv_from(coo_prol)
   call op_restr%mv_from(coo_restr)
 
@@ -303,7 +308,7 @@ contains
   subroutine omega_smooth(omega,acsr)
     implicit none 
     real(psb_dpk_),intent(in) :: omega
-    type(psb_ld_csr_sparse_mat), intent(inout) :: acsr
+    type(psb_d_csr_sparse_mat), intent(inout) :: acsr
     !
     integer(psb_lpk_) :: i,j
     do i=1,acsr%get_nrows()

mlprec/impl/aggregator/mld_s_dec_aggregator_mat_asb.f90

@@ -83,7 +83,7 @@
 !    info       -  integer, output.
 !                  Error code.
 !  
-subroutine  mld_s_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
+subroutine  mld_s_dec_aggregator_mat_asb(ag,parms,a,desc_a,&
      & ac,desc_ac, op_prol,op_restr,info)
   use psb_base_mod
   use mld_base_prec_type
@@ -93,16 +93,13 @@ subroutine  mld_s_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   type(mld_sml_parms), intent(inout)  :: parms 
   type(psb_sspmat_type), intent(in)    :: a
   type(psb_desc_type), intent(inout)     :: desc_a
-  integer(psb_lpk_), intent(inout)       :: ilaggr(:), nlaggr(:)
-  type(psb_lsspmat_type), intent(inout) :: op_prol, ac,op_restr
+  type(psb_sspmat_type), intent(inout) :: op_prol, ac,op_restr
   type(psb_desc_type), intent(inout)     :: desc_ac
   integer(psb_ipk_), intent(out)         :: info
   !
   integer(psb_ipk_)              :: ictxt, np, me
-  type(psb_ls_coo_sparse_mat)  :: lacoo, lbcoo
-  type(psb_s_coo_sparse_mat)   :: acoo
-  type(psb_ls_csr_sparse_mat)  :: acsr1
-  type(psb_sspmat_type)        :: tmp_ac
+  type(psb_ls_coo_sparse_mat)  :: tmpcoo
+  type(psb_lsspmat_type)       :: tmp_ac
   integer(psb_ipk_)              :: i_nr, i_nc, i_nl, nzl
   integer(psb_lpk_)              :: ntaggr
   integer(psb_ipk_) :: err_act, debug_level, debug_unit
@@ -117,70 +114,13 @@ subroutine  mld_s_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   ictxt = desc_a%get_context()
   call psb_info(ictxt,me,np)
 
-
-
-  ntaggr = sum(nlaggr)
-
   select case(parms%coarse_mat)
 
   case(mld_distr_mat_) 
 
-    call ac%mv_to(lbcoo)
-    nzl  = lbcoo%get_nzeros()
-    i_nl = nlaggr(me+1)
-    if (info == psb_success_) call psb_cdall(ictxt,desc_ac,info,nl=i_nl)
-    if (info == psb_success_) call psb_cdins(nzl,lbcoo%ia,lbcoo%ja,desc_ac,info)
-    if (info == psb_success_) call psb_cdasb(desc_ac,info)
-    if (info == psb_success_) call psb_glob_to_loc(lbcoo%ia(1:nzl),desc_ac,info,iact='I')
-    if (info == psb_success_) call psb_glob_to_loc(lbcoo%ja(1:nzl),desc_ac,info,iact='I')
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Creating desc_ac and converting ac')
-      goto 9999
-    end if
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Assembld aux descr. distr.'
-    call ac%mv_from(lbcoo)
-    call ac%set_nrows(desc_ac%get_local_rows())
-    call ac%set_ncols(desc_ac%get_local_cols())
-    call ac%set_asb()
-
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
-      goto 9999
-    end if
-
-    if (np>1) then 
-      call op_prol%mv_to(acsr1)
-      nzl = acsr1%get_nzeros()
-      call psb_glob_to_loc(acsr1%ja(1:nzl),desc_ac,info,'I')
-      if(info /= psb_success_) then
-        call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
-        goto 9999
-      end if
-      call op_prol%mv_from(acsr1)
-    endif
-    call op_prol%set_ncols(desc_ac%get_local_cols())
-
-    if (np>1) then 
-      !call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
-      call op_restr%mv_to(lacoo)
-      nzl = lacoo%get_nzeros()
-      if (info == psb_success_) call psb_glob_to_loc(lacoo%ia(1:nzl),desc_ac,info,'I')
-      call lacoo%set_dupl(psb_dupl_add_)
-      if (info == psb_success_) call op_restr%mv_from(lacoo)
-      if (info == psb_success_) call op_restr%cscnv(info,type='csr')        
-      if(info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Converting op_restr to local')
-        goto 9999
-      end if
-    end if
-    !
-    ! Clip to local rows.
-    !
-    call op_restr%set_nrows(desc_ac%get_local_rows())
+    call ac%cscnv(info,type='csr')
+    call op_prol%cscnv(info,type='csr')
+    call op_restr%cscnv(info,type='csr')
 
     if (debug_level >= psb_debug_outer_) &
          & write(debug_unit,*) me,' ',trim(name),&
@@ -188,23 +128,39 @@ subroutine  mld_s_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
 
   case(mld_repl_mat_) 
     !
+    ! We are assuming here that an s matrix
+    ! can hold all entries
     !
-    ! If we are here, it means we assume that an IPK version of the
-    ! coarse matrix can hold all indices. User beware!
-    !
+    if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
+      ntaggr = desc_ac%get_global_rows()
+      i_nr   = ntaggr
+    else
+      info = psb_err_internal_error_
+      call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
+      goto 9999
+    end if
+    
+    call op_prol%mv_to(tmpcoo)
+    nzl = tmpcoo%get_nzeros()
+    call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
+    call tmpcoo%set_ncols(i_nr)
+    call op_prol%mv_from(tmpcoo)
+
+    call op_restr%mv_to(tmpcoo)
+    nzl = tmpcoo%get_nzeros()
+    call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
+    call tmpcoo%set_nrows(i_nr)
+    call op_restr%mv_from(tmpcoo)
+
+
+    call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
+         & dupl=psb_dupl_add_,keeploc=.false.)
+    call tmp_ac%mv_to(tmpcoo)
+    call ac%mv_from(tmpcoo)
     
-    !
-    ! op_prol/op_restr come from par_spmm_bld with local sizes
-    ! suitable for DIST option, fix relevant sizes
-    ! 
-    call op_prol%set_ncols(ntaggr)
-    call op_restr%set_nrows(ntaggr)
     call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
     if (info == psb_success_) call psb_cdasb(desc_ac,info)
-    if (info == psb_success_) call ac%mv_to(acoo)
-    if (info == psb_success_) call tmp_ac%mv_from(acoo)
-    if (info == psb_success_) &
-         & call psb_gather(ac,tmp_ac,desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)     
+
     if (info /= psb_success_) goto 9999
 
   case default 
@@ -221,4 +177,19 @@ subroutine  mld_s_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   return
 
 
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_ls_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
 end subroutine mld_s_dec_aggregator_mat_asb

mlprec/impl/aggregator/mld_s_dec_aggregator_mat_bld.f90

@@ -133,7 +133,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !  
-subroutine  mld_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_prol,op_restr,info)
+subroutine  mld_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_s_prec_type, mld_protect_name => mld_s_dec_aggregator_mat_bld
   use mld_s_inner_mod 
@@ -144,15 +145,14 @@ subroutine  mld_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_p
   type(psb_sspmat_type), intent(in)    :: a
   type(psb_desc_type), intent(inout)     :: desc_a
   integer(psb_lpk_), intent(inout)     :: ilaggr(:), nlaggr(:)
-  type(psb_lsspmat_type), intent(inout)   :: op_prol
-  type(psb_lsspmat_type), intent(out)   :: ac,op_restr
+  type(psb_lsspmat_type), intent(inout)   :: t_prol
+  type(psb_sspmat_type), intent(out)   :: op_prol,ac,op_restr
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)       :: info
 
   ! Local variables
   character(len=20)            :: name
   integer(psb_mpk_)            :: ictxt, np, me
-  type(psb_ls_coo_sparse_mat) :: acoo, bcoo
-  type(psb_ls_csr_sparse_mat) :: acsr1
   integer(psb_lpk_)            :: nzl,ntaggr
   integer(psb_ipk_)            :: err_act
   integer(psb_ipk_)            :: debug_level, debug_unit
@@ -177,22 +177,22 @@ subroutine  mld_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_p
   case (mld_no_smooth_) 
 
     call mld_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,&
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case(mld_smooth_prol_) 
 
     call mld_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
-  case(mld_biz_prol_) 
-
-    call mld_saggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+!!$  case(mld_biz_prol_) 
+!!$
+!!$    call mld_saggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
+!!$         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case(mld_min_energy_) 
 
     call mld_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case default
     info = psb_err_internal_error_

mlprec/impl/aggregator/mld_s_dec_aggregator_tprol.f90

@@ -68,14 +68,14 @@
 !                  overlap.
 !    nlaggr     -  integer, dimension(:), allocatable, output
 !                  nlaggr(i) contains the aggregates held by process i.
-!    op_prol    -  type(psb_sspmat_type), output
+!    t_prol    -  type(psb_sspmat_type), output
 !               The tentative prolongator, based on ilaggr.
 !               
 !    info    -  integer, output.
 !               Error code.         
 !  
 subroutine  mld_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
-     & a,desc_a,ilaggr,nlaggr,op_prol,info)
+     & a,desc_a,ilaggr,nlaggr,t_prol,info)
   use psb_base_mod
   use mld_s_prec_type, mld_protect_name => mld_s_dec_aggregator_build_tprol
   use mld_s_inner_mod
@@ -86,7 +86,7 @@ subroutine  mld_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
   type(psb_sspmat_type), intent(in)   :: a
   type(psb_desc_type), intent(in)     :: desc_a
   integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
-  type(psb_lsspmat_type), intent(out)  :: op_prol
+  type(psb_lsspmat_type), intent(out)  :: t_prol
   integer(psb_ipk_), intent(out)      :: info
 
   ! Local variables
@@ -123,7 +123,7 @@ subroutine  mld_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
   clean_zeros = ag%do_clean_zeros
   call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
 
-  if (info==psb_success_) call mld_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
+  if (info==psb_success_) call mld_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

mlprec/impl/aggregator/mld_s_map_to_tprol.f90

@@ -124,9 +124,9 @@ subroutine mld_s_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
     goto 9999
   end if
 
-  call tmpcoo%allocate(ncol,ntaggr,ncol)
+  call tmpcoo%allocate(nrow,ntaggr,ncol)
   k = 0 
-  do i=1,ncol
+  do i=1,nrow
     !
     ! Note: at this point, a value ilaggr(i)<=0
     ! tags a "singleton" row, and it has to be

mlprec/impl/aggregator/mld_s_ptap.f90

@@ -0,0 +1,689 @@
+!   
+!   
+!                             MLD2P4  Extensions
+!    
+!    (C) Copyright 2019
+!  
+!                        Salvatore Filippone  Cranfield University
+!        Pasqua D'Ambra         IAC-CNR, Naples, IT
+!   
+!    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.
+!   
+!  
+! File: mld_daggrmat_nosmth_bld.F90
+!
+!
+subroutine mld_s_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_s_inner_mod
+  use mld_s_base_aggregator_mod, mld_protect_name => mld_s_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_s_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)          :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_sml_parms), intent(inout)         :: parms 
+  type(psb_s_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_sspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_ls_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_s_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nglob, ntaggr, naggrm1, naggrp1
+  integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_fmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      call coo_prol%cp_to_coo(coo_restr,info)
+      call coo_restr%set_ncols(desc_ac%get_local_cols())
+      call coo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_s_coo_glob_transpose(coo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call coo_restr%set_nrows(desc_ac%get_local_rows())
+      call coo_restr%set_ncols(desc_ax%get_local_cols())
+!!$      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+!!$           & desc_a%get_local_cols(),desc_ax%get_local_cols(),coo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+    end block
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_coo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_s_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_s_ptap
+
+subroutine mld_s_ls_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_s_inner_mod
+  use mld_s_base_aggregator_mod !, mld_protect_name => mld_s_ls_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_s_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)          :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_sml_parms), intent(inout)         :: parms 
+  type(psb_ls_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_lsspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_ls_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_s_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
+       &  nzt, naggrm1, naggrp1, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_ifmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      type(psb_s_coo_sparse_mat) :: icoo_restr
+
+      call coo_prol%cp_to_icoo(icoo_restr,info)
+      call icoo_restr%set_ncols(desc_ac%get_local_cols())
+      call icoo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_s_coo_glob_transpose(icoo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call icoo_restr%set_nrows(desc_ac%get_local_rows())
+      call icoo_restr%set_ncols(desc_ax%get_local_cols())
+      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+           & desc_a%get_local_cols(),desc_ax%get_local_cols(),icoo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+      call coo_restr%cp_from_icoo(icoo_restr,info)
+    end block
+    call csr_restr%cp_from_lcoo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_lcoo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_lcoo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_ls_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_s_ls_ptap
+
+subroutine mld_ls_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_s_inner_mod
+  use mld_s_base_aggregator_mod!, mld_protect_name => mld_ls_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_ls_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)           :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_sml_parms), intent(inout)         :: parms 
+  type(psb_ls_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_lsspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_ls_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_ls_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
+       &  nzt, naggrm1, naggrp1, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_fmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      type(psb_s_coo_sparse_mat) :: icoo_restr
+
+      call coo_prol%cp_to_icoo(icoo_restr,info)
+      call icoo_restr%set_ncols(desc_ac%get_local_cols())
+      call icoo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_s_coo_glob_transpose(icoo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call icoo_restr%set_nrows(desc_ac%get_local_rows())
+      call icoo_restr%set_ncols(desc_ax%get_local_cols())
+      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+           & desc_a%get_local_cols(),desc_ax%get_local_cols(),icoo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+      call coo_restr%cp_from_icoo(icoo_restr,info)
+    end block
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_coo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  !call coo_restr%mv_from_ifmt(csr_restr,info)
+!!$    call coo_restr%set_nrows(desc_ac%get_local_rows())
+!!$    call coo_restr%set_ncols(desc_a%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_ls_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_ls_ptap

mlprec/impl/aggregator/mld_s_spmm_bld_inner.f90

@@ -1,390 +0,0 @@
-!   
-!   
-!                             MLD2P4  Extensions
-!    
-!    (C) Copyright 2019
-!  
-!                        Salvatore Filippone  Cranfield University
-!        Pasqua D'Ambra         IAC-CNR, Naples, IT
-!   
-!    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.
-!   
-!  
-! File: mld_daggrmat_nosmth_bld.F90
-!
-!
-subroutine mld_s_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,&
-     & coo_prol,desc_cprol,coo_restr,info)
-  use psb_base_mod
-  use mld_s_inner_mod
-  use mld_s_base_aggregator_mod, mld_protect_name => mld_s_spmm_bld_inner
-  implicit none
-
-  ! Arguments
-  type(psb_s_csr_sparse_mat), intent(inout) :: a_csr
-  type(psb_desc_type), intent(in)            :: desc_a
-  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
-  type(mld_sml_parms), intent(inout)         :: parms 
-  type(psb_ls_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
-  type(psb_desc_type), intent(inout)         :: desc_cprol
-  type(psb_lsspmat_type), intent(out)        :: ac
-  integer(psb_ipk_), intent(out)             :: info
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
-  character(len=40)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_ls_coo_sparse_mat) :: ac_coo, tmpcoo
-  type(psb_s_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
-  integer(psb_ipk_) :: debug_level, debug_unit, naggr
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
-       &  nzt, naggrm1, naggrp1, i, k
-  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
-  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
-
-  name='mld_spmm_bld_inner'
-  if(psb_get_errstatus().ne.0) return 
-  info=psb_success_
-  call psb_erractionsave(err_act)
-
-
-  ictxt = desc_a%get_context()
-  icomm = desc_a%get_mpic()
-  call psb_info(ictxt, me, np)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
-
-  naggr   = nlaggr(me+1)
-  ntaggr  = sum(nlaggr)
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1)) 
-  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
-
-  !
-  ! COO_PROL should arrive here with local numbering
-  !
-  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
-       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
-       & nrow,ntaggr,naggr
-
-  call coo_prol%cp_to_ifmt(csr_prol,info)
-
-  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
-       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
-       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols()
-  if (debug) flush(0)
-
-  if (do_timings) call psb_tic(idx_spspmm)
-  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)  
-
-  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
-       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
-       & desc_cprol%get_local_rows(),desc_cprol%get_local_cols()
-
-  !
-  ! Ok first product done.
-  !
-  ! Remember that RESTR must be built from PROL after halo extension,
-  ! which is done above in psb_par_spspmm
-  if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
-       & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
-  call csr_prol%cp_to_lcoo(coo_restr,info)
-!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
-!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
-  call coo_restr%transp()
-  nzl = coo_restr%get_nzeros()
-  call desc_cprol%l2gip(coo_restr%ia(1:nzl),info)
-  i=0
-  !
-  ! Now we have to fix this.  The only rows of the restrictor that are correct 
-  ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-  !
-  do k=1, nzl
-    if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then
-      i = i+1
-      coo_restr%val(i) = coo_restr%val(k)
-      coo_restr%ia(i)  = coo_restr%ia(k)
-      coo_restr%ja(i)  = coo_restr%ja(k)
-    end if
-  end do
-  call coo_restr%set_nzeros(i)
-  call coo_restr%fix(info)
-  call coo_restr%cp_to_coo(tmpcoo,info)
-!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
-
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
-    goto 9999
-  end if
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'starting sphalo/ rwxtd'
-  nzl    = tmpcoo%get_nzeros()    
-  call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_cprol,info,iact='I',owned=.true.)
-  call tmpcoo%clean_negidx(info)
-  nzl  = tmpcoo%get_nzeros()
-  call tmpcoo%set_nrows(desc_cprol%get_local_rows())
-  call tmpcoo%set_ncols(desc_a%get_local_cols())
-!!$    write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros()      
-  call csr_restr%mv_from_lcoo(tmpcoo,info)
-
-  if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
-       & csr_restr%get_nrows(),csr_restr%get_ncols(), &
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols(),&
-       & acsr3%get_nrows(),acsr3%get_ncols()
-  if (do_timings) call psb_tic(idx_spspmm)      
-  call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)      
-  call csr_restr%free()
-  call acsr3%free()
-  call ac_csr%mv_to_lcoo(ac_coo,info)
-  call ac_coo%fix(info)
-  nza    = ac_coo%get_nzeros()
-  if (debug) write(0,*) me,trim(name),' Fixed ac ',&
-       & ac_coo%get_nrows(),ac_coo%get_ncols(), nza
-  call desc_cprol%indxmap%l2gip(ac_coo%ia(1:nza),info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ja(1:nza),info)
-  call ac_coo%set_nrows(ntaggr)
-  call ac_coo%set_ncols(ntaggr)
-  if (debug) write(0,*)  me,' ',trim(name),' Before mv_from',psb_get_errstatus()
-  if (info == 0) call ac%mv_from(ac_coo)
-  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
-  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
-  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
-
-  nza = coo_prol%get_nzeros()
-  call desc_cprol%indxmap%l2gip(coo_prol%ja(1:nza),info)
-  
-  if (debug) then
-    write(0,*) me,' ',trim(name),' Checkpoint at exit'
-    call psb_barrier(ictxt)
-    write(0,*) me,' ',trim(name),' Checkpoint through'
-  end if
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done spmm_bld_inner '
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-  
-end subroutine mld_s_spmm_bld_inner
-
-subroutine mld_ls_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,&
-     & coo_prol,desc_cprol,coo_restr,info)
-  use psb_base_mod
-  use mld_s_inner_mod
-  use mld_s_base_aggregator_mod, mld_protect_name => mld_ls_spmm_bld_inner
-  implicit none
-
-  ! Arguments
-  type(psb_ls_csr_sparse_mat), intent(inout) :: a_csr
-  type(psb_desc_type), intent(in)            :: desc_a
-  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
-  type(mld_sml_parms), intent(inout)         :: parms 
-  type(psb_ls_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
-  type(psb_desc_type), intent(inout)         :: desc_cprol
-  type(psb_lsspmat_type), intent(out)        :: ac
-  integer(psb_ipk_), intent(out)             :: info
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
-  character(len=40)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_ls_coo_sparse_mat) :: ac_coo, tmpcoo
-  type(psb_ls_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
-  integer(psb_ipk_) :: debug_level, debug_unit, naggr
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
-       &  nzt, naggrm1, naggrp1, i, k
-  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
-  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
-
-  name='mld_spmm_bld_inner'
-  if(psb_get_errstatus().ne.0) return 
-  info=psb_success_
-  call psb_erractionsave(err_act)
-
-
-  ictxt = desc_a%get_context()
-  icomm = desc_a%get_mpic()
-  call psb_info(ictxt, me, np)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
-
-  naggr   = nlaggr(me+1)
-  ntaggr  = sum(nlaggr)
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1)) 
-  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
-
-  !
-  ! Here COO_PROL should be with GLOBAL indices on the cols
-  ! and LOCAL indices on the rows. 
-  !
-  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
-       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
-       & nrow,ntaggr,naggr
-
-  call coo_prol%cp_to_fmt(csr_prol,info)
-
-  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
-       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
-       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols()
-  if (debug) flush(0)
-
-  if (do_timings) call psb_tic(idx_spspmm)
-  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)  
-
-  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
-       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
-       & desc_cprol%get_local_rows(),desc_cprol%get_local_cols()
-
-  !
-  ! Ok first product done.
-  !
-  ! Remember that RESTR must be built from PROL after halo extension,
-  ! which is done above in psb_par_spspmm
-  if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
-       & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
-  call csr_prol%cp_to_fmt(coo_restr,info)
-!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
-!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
-  call coo_restr%transp()
-  nzl = coo_restr%get_nzeros()
-  call desc_cprol%l2gip(coo_restr%ia(1:nzl),info)
-  i=0
-  !
-  ! Now we have to fix this.  The only rows of the restrictor that are correct 
-  ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-  !
-  do k=1, nzl
-    if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then
-      i = i+1
-      coo_restr%val(i) = coo_restr%val(k)
-      coo_restr%ia(i)  = coo_restr%ia(k)
-      coo_restr%ja(i)  = coo_restr%ja(k)
-    end if
-  end do
-  call coo_restr%set_nzeros(i)
-  call coo_restr%fix(info)
-  call coo_restr%cp_to_coo(tmpcoo,info)
-!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
-
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
-    goto 9999
-  end if
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'starting sphalo/ rwxtd'
-  nzl    = tmpcoo%get_nzeros()    
-  call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_cprol,info,iact='I',owned=.true.)
-  call tmpcoo%clean_negidx(info)
-  nzl  = tmpcoo%get_nzeros()
-  call tmpcoo%set_nrows(desc_cprol%get_local_rows())
-  call tmpcoo%set_ncols(desc_a%get_local_cols())
-!!$    write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros()      
-  call csr_restr%mv_from_coo(tmpcoo,info)
-
-  if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
-       & csr_restr%get_nrows(),csr_restr%get_ncols(), &
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols(),&
-       & acsr3%get_nrows(),acsr3%get_ncols()
-  if (do_timings) call psb_tic(idx_spspmm)      
-  call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)      
-  call csr_restr%free()
-  call ac_csr%mv_to_coo(ac_coo,info)
-  nza    = ac_coo%get_nzeros()
-  if (debug) write(0,*) me,trim(name),' Fixing ac ',&
-       & ac_coo%get_nrows(),ac_coo%get_ncols(), nza
-  call ac_coo%fix(info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ia(1:nza),info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ja(1:nza),info)
-  call ac_coo%set_nrows(ntaggr)
-  call ac_coo%set_ncols(ntaggr)
-  if (debug) write(0,*)  me,' ',trim(name),' Before mv_from',psb_get_errstatus()
-  if (info == 0) call ac%mv_from(ac_coo)
-  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
-  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
-  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
-
-  nza = coo_prol%get_nzeros()
-  call desc_cprol%indxmap%l2gip(coo_prol%ja(1:nza),info)
-  
-  if (debug) then
-    write(0,*) me,' ',trim(name),' Checkpoint at exit'
-    call psb_barrier(ictxt)
-    write(0,*) me,' ',trim(name),' Checkpoint through'
-  end if
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done spmm_bld_inner '
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-  
-end subroutine mld_ls_spmm_bld_inner

mlprec/impl/aggregator/mld_saggrmat_biz_bld.f90

@@ -1,300 +0,0 @@
-!   
-!   
-!                             MLD2P4  version 2.2
-!    MultiLevel Domain Decomposition Parallel Preconditioners Package
-!               based on PSBLAS (Parallel Sparse BLAS version 3.5)
-!    
-!    (C) Copyright 2008-2018 
-!  
-!        Salvatore Filippone  
-!        Pasqua D'Ambra   
-!        Daniela di Serafino   
-!   
-!    Redistribution and use in source and binary forms, with or without
-!    modification, are permitted provided that the following conditions
-!    are met:
-!      1. Redistributions of source code must retain the above copyright
-!         notice, this list of conditions and the following disclaimer.
-!      2. Redistributions in binary form must reproduce the above copyright
-!         notice, this list of conditions, and the following disclaimer in the
-!         documentation and/or other materials provided with the distribution.
-!      3. The name of the 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.
-!   
-!  
-! File: mld_saggrmat_biz_bld.F90
-!
-! Subroutine: mld_saggrmat_biz_bld
-! Version:    real
-!
-!  This routine builds a coarse-level matrix A_C from a fine-level matrix A
-!  by using the Galerkin approach, i.e.
-!
-!                               A_C = P_C^T A P_C,
-!
-!  where P_C is a prolongator from the coarse level to the fine one.
-! 
-!  This routine builds A_C according to a "bizarre" aggregation algorithm,
-!  using a "naive" prolongator proposed by the authors of MLD2P4. However, this
-!  prolongator still requires additional analysis and testing and its use is not
-!  recommended.
-!
-!  The coarse-level matrix A_C is distributed among the parallel processes or
-!  replicated on each of them, according to the value of p%parms%coarse_mat,
-!  specified by the user through mld_sprecinit and mld_zprecset.
-!  On output from this routine the entries of AC, op_prol, op_restr
-!  are still in "global numbering" mode; this is fixed in the calling routine
-!  mld_s_lev_aggrmat_bld.
-!
-! Arguments:
-!    a          -  type(psb_sspmat_type), input.     
-!                  The sparse matrix structure containing the local part of
-!                  the fine-level matrix.
-!    desc_a     -  type(psb_desc_type), input.
-!                  The communication descriptor of the fine-level matrix.
-!    p          -  type(mld_s_onelev_type), input/output.
-!                  The 'one-level' data structure that will contain the local
-!                  part of the matrix to be built as well as the information 
-!                  concerning the prolongator and its transpose.
-!    ilaggr     -  integer, dimension(:), allocatable.
-!                  The mapping between the row indices of the coarse-level
-!                  matrix and the row indices of the fine-level matrix.
-!                  ilaggr(i)=j means that node i in the adjacency graph
-!                  of the fine-level matrix is mapped onto node j in the
-!                  adjacency graph of the coarse-level matrix.
-!    nlaggr     -  integer, dimension(:), allocatable.
-!                  nlaggr(i) contains the aggregates held by process i.
-!    info       -  integer, output.
-!                  Error code.
-!
-subroutine mld_saggrmat_biz_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
-  use psb_base_mod
-  use mld_base_prec_type
-  use mld_s_inner_mod, mld_protect_name => mld_saggrmat_biz_bld
-  use mld_s_base_aggregator_mod
-  
-  implicit none
-
-  ! Arguments
-  type(psb_sspmat_type), intent(in)      :: a
-  type(psb_desc_type), intent(in)          :: desc_a
-  integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
-  type(mld_sml_parms), intent(inout)    :: parms 
-  type(psb_lsspmat_type), intent(inout)  :: op_prol
-  type(psb_lsspmat_type), intent(out)    :: ac,op_restr
-  integer(psb_ipk_), intent(out)           :: info
-
-  ! Local variables
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
-       & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
-  integer(psb_ipk_) :: inaggr, nzlp, inrow
-  integer(psb_ipk_) :: ictxt, np, me
-  character(len=20) :: name
-  type(psb_desc_type) :: tmp_desc
-  type(psb_s_coo_sparse_mat)  :: icoo
-  type(psb_ls_coo_sparse_mat) :: coo_prol, coo_restr, tmpcoo
-  type(psb_ls_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
-  real(psb_spk_), allocatable :: adiag(:)
-  real(psb_spk_), allocatable :: arwsum(:)
-  integer(psb_ipk_)  :: ierr(5)
-  logical            :: filter_mat
-  integer(psb_ipk_)            :: debug_level, debug_unit, err_act
-  integer(psb_ipk_), parameter :: ncmax=16
-  real(psb_spk_)     :: anorm, omega, tmp, dg, theta
-  logical, parameter :: debug_new=.false.
-  character(len=80) :: filename
-
-  name='mld_aggrmat_biz_bld'
-  info=psb_success_
-  call psb_erractionsave(err_act)
-  if (psb_errstatus_fatal()) then
-    info = psb_err_internal_error_; goto 9999
-  end if
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-
-  ictxt = desc_a%get_context()
-
-  call psb_info(ictxt, me, np)
-
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  theta = parms%aggr_thresh
-
-  naggr  = nlaggr(me+1)
-  ntaggr = sum(nlaggr)
-
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1))
-  filter_mat = (parms%aggr_filter == mld_filter_mat_)
-
-  !
-  ! naggr: number of local aggregates
-  ! nrow: local rows. 
-  ! 
-
-  ! Get the diagonal D
-  adiag = a%get_diag(info)
-  if (info == psb_success_) &
-       & call psb_realloc(ncol,adiag,info)
-  if (info == psb_success_) &
-       & call psb_halo(adiag,desc_a,info)
-  if (info == psb_success_) call a%csclip(icoo,info,jmax=a%get_nrows())
-  call icoo%mv_to_lfmt(acsr,info)
-  call op_prol%mv_to(coo_prol)
-
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
-    goto 9999
-  end if
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & ' Initial copies done.'
-
-  call acsr%cp_to_fmt(acsrf,info)
-
-
-  if (filter_mat) then
-    !
-    ! Build the filtered matrix Af from A
-    ! 
-
-    do i=1, nrow
-      tmp = szero
-      jd  = -1 
-      do j=acsrf%irp(i),acsrf%irp(i+1)-1
-        if (acsrf%ja(j) == i) jd = j 
-        if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
-          tmp=tmp+acsrf%val(j)
-          acsrf%val(j)=szero
-        endif
-
-      enddo
-      if (jd == -1) then 
-        write(0,*) 'Wrong input: we need the diagonal!!!!', i
-      else
-        acsrf%val(jd)=acsrf%val(jd)-tmp
-      end if
-    enddo
-    ! Take out zeroed terms 
-    call acsrf%clean_zeros(info)
-  end if
-
-
-  do i=1,size(adiag)
-    if (adiag(i) /= szero) then
-      adiag(i) = sone / adiag(i)
-    else
-      adiag(i) = sone
-    end if
-  end do
-
-  if (parms%aggr_omega_alg == mld_eig_est_) then 
-
-    if (parms%aggr_eig == mld_max_norm_) then 
-      allocate(arwsum(nrow))
-      call acsr%arwsum(arwsum)      
-      anorm = maxval(abs(adiag(1:nrow)*arwsum(1:nrow)))
-      call psb_amx(ictxt,anorm)
-      omega = 4.d0/(3.d0*anorm)
-      parms%aggr_omega_val = omega 
-
-    else 
-      info = psb_err_internal_error_
-      call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
-      goto 9999
-    end if
-
-  else if (parms%aggr_omega_alg == mld_user_choice_) then 
-
-    omega = parms%aggr_omega_val 
-
-  else if (parms%aggr_omega_alg /= mld_user_choice_) then 
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
-    goto 9999
-  end if
-
-  
-  call acsrf%scal(adiag,info)
-  if (info /= psb_success_) goto 9999
-
-  inaggr = naggr
-  call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-  nzlp = coo_prol%get_nzeros()
-  call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-  call coo_prol%set_ncols(tmp_desc%get_local_cols())
-  call coo_prol%mv_to_fmt(csr_prol,info)  
-  !
-  ! Build the smoothed prolongator using either A or Af
-  !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
-  ! This is always done through the variable acsrf which
-  ! is a bit less readable, butsaves space and one extra matrix copy
-  ! 
-  call omega_smooth(omega,acsrf)
-  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,tmp_desc,info)
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done SPSPMM 1'
-  nzl = acsr1%get_nzeros()
-  call acsr1%mv_to_coo(coo_prol,info)
-  
-  call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-       & coo_prol,tmp_desc,coo_restr,info)
-  
-  call op_prol%mv_from(coo_prol)
-  call op_restr%mv_from(coo_restr)
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done smooth_aggregate '
-  call psb_erractionrestore(err_act)
-  return
-
-9999 continue
-  call psb_errpush(info,name)
-  call psb_error_handler(err_act)
-  return
-
-contains
-
-  subroutine omega_smooth(omega,acsr)
-    implicit none 
-    real(psb_spk_),intent(in) :: omega
-    type(psb_ls_csr_sparse_mat), intent(inout) :: acsr
-    !
-    integer(psb_lpk_) :: i,j
-    do i=1,acsr%get_nrows()
-      do j=acsr%irp(i),acsr%irp(i+1)-1
-        if (acsr%ja(j) == i) then 
-          acsr%val(j) = sone - omega*acsr%val(j) 
-        else
-          acsr%val(j) = - omega*acsr%val(j) 
-        end if
-      end do
-    end do
-  end subroutine omega_smooth
-
-end subroutine mld_saggrmat_biz_bld

mlprec/impl/aggregator/mld_saggrmat_minnrg_bld.f90

@@ -104,7 +104,8 @@
 !                  Error code.
 !
 !
-subroutine mld_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_s_inner_mod, mld_protect_name => mld_saggrmat_minnrg_bld
@@ -113,11 +114,12 @@ subroutine mld_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 
   ! Arguments
   type(psb_sspmat_type), intent(in)           :: a
-  type(psb_desc_type), intent(in)               :: desc_a
+  type(psb_desc_type), intent(inout)            :: desc_a
   integer(psb_lpk_), intent(inout)              :: ilaggr(:), nlaggr(:)
   type(mld_sml_parms), intent(inout)         :: parms 
   type(psb_lsspmat_type), intent(inout)       :: op_prol
   type(psb_lsspmat_type), intent(out)         :: ac,op_restr
+  type(psb_desc_type), intent(inout)            :: desc_ac
   integer(psb_ipk_), intent(out)                :: info
 
   ! Local variables

mlprec/impl/aggregator/mld_saggrmat_nosmth_bld.f90

@@ -96,7 +96,8 @@
 !                  Error code.
 !
 !
-subroutine mld_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_s_inner_mod, mld_protect_name => mld_saggrmat_nosmth_bld
@@ -105,26 +106,26 @@ subroutine mld_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 
   ! Arguments
   type(psb_sspmat_type), intent(in)        :: a
-  type(psb_desc_type), intent(in)            :: desc_a
+  type(psb_desc_type), intent(inout)         :: desc_a
   integer(psb_lpk_), intent(inout)           :: ilaggr(:), nlaggr(:)
   type(mld_sml_parms), intent(inout)      :: parms 
-  type(psb_lsspmat_type), intent(inout)    :: op_prol
-  type(psb_lsspmat_type), intent(out)      :: ac,op_restr
+  type(psb_sspmat_type), intent(inout)       :: op_prol,ac,op_restr
+  type(psb_lsspmat_type), intent(inout)    :: t_prol
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)             :: info
 
   ! Local variables
   integer(psb_ipk_)  :: err_act
   integer(psb_ipk_)  :: ictxt, np, me, icomm,  minfo
   character(len=20)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_lsspmat_type)      :: la 
-  type(psb_ls_coo_sparse_mat) :: ac_coo, tmpcoo, coo_prol, coo_restr
-  type(psb_ls_csr_sparse_mat) :: acsr1, acsr2, acsr
-  type(psb_desc_type) :: tmp_desc
+  type(psb_ls_coo_sparse_mat) :: lcoo_prol
+  type(psb_s_coo_sparse_mat) :: coo_prol, coo_restr
+  type(psb_s_csr_sparse_mat) :: acsr
   integer(psb_ipk_) :: debug_level, debug_unit
   integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
        & naggr, nzt, naggrm1, naggrp1, i, k
   integer(psb_ipk_) :: inaggr, nzlp
+  logical, parameter :: debug = .false.
 
   name = 'mld_aggrmat_nosmth_bld'
   info = psb_success_
@@ -145,71 +146,32 @@ subroutine mld_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
   naggrm1 = sum(nlaggr(1:me))
   naggrp1 = sum(nlaggr(1:me+1))
 
-  if (.false.) then
-    !
-    ! If we ever want to switch to explicit product when building this..
-    !
-    call a%cp_to(acsr)
-    call op_prol%mv_to(coo_prol)
-    inaggr = naggr
-    call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-    nzlp = coo_prol%get_nzeros()
-    call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-    call coo_prol%set_ncols(tmp_desc%get_local_cols())
-    call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-         & coo_prol,tmp_desc,coo_restr,info)
+  call a%cp_to(acsr)
+  call t_prol%mv_to(lcoo_prol)
+  inaggr = naggr
+  call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
+  nzlp = lcoo_prol%get_nzeros()
+  call desc_ac%indxmap%g2lip_ins(lcoo_prol%ja(1:nzlp),info) 
+  call lcoo_prol%set_ncols(desc_ac%get_local_cols())
+  call lcoo_prol%cp_to_icoo(coo_prol,info)
+  
+  if (debug) call check_coo(me,trim(name)//' Check 1 on  coo_prol:',coo_prol)
 
-    call op_prol%mv_from(coo_prol)
-    call op_restr%mv_from(coo_restr)
+  call psb_cdasb(desc_ac,info)
+  call psb_cd_reinit(desc_ac,info)
 
+  call mld_ptap(acsr,desc_a,nlaggr,parms,ac,&
+       & coo_prol,desc_ac,coo_restr,info)
 
-  else
-    
-    call a%cp_to(ac_coo)
-    nzt = ac_coo%get_nzeros()
-    k   = 0
-    do i = 1, nzt 
-      k = k + 1 
-      ac_coo%ia(k)  = ilaggr(ac_coo%ia(i))
-      ac_coo%ja(k)  = ilaggr(ac_coo%ja(i))
-      ac_coo%val(k) = ac_coo%val(i)
-      ! At this point, there may be negative entries,
-      ! because that's how ILAGGR marks singletons
-      ! If this is the case, roll back K
-      if ((ac_coo%ia(k)<=0).or.(ac_coo%ja(k)<=0)) k = k-1      
-    enddo
-    call ac_coo%set_nrows(naggr)
-    call ac_coo%set_ncols(naggr)
-    call ac_coo%set_nzeros(k)
-    call ac_coo%set_dupl(psb_dupl_add_)
-    call ac_coo%fix(info)
-    call ac_coo%trim()
-    call ac%mv_from(ac_coo) 
+  call coo_restr%set_nrows(desc_ac%get_local_rows())
+  call coo_restr%set_ncols(desc_a%get_local_cols())
+  call coo_prol%set_nrows(desc_a%get_local_rows())
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
 
-    call op_prol%cp_to(tmpcoo)
+  if (debug) call check_coo(me,trim(name)//' Check 1 on coo_restr:',coo_restr)
 
-    call tmpcoo%transp()
-    !
-    ! Now we have to fix this.  The only rows of tmpcoo/op_restr that are correct 
-    ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-    !
-    nzl = tmpcoo%get_nzeros()
-    i   = 0
-    do k = 1, nzl
-      if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
-        i = i+1
-        tmpcoo%val(i) = tmpcoo%val(k)
-        tmpcoo%ia(i)  = tmpcoo%ia(k)
-        tmpcoo%ja(i)  = tmpcoo%ja(k)
-      end if
-    end do
-    call tmpcoo%set_nzeros(i)
-    call tmpcoo%trim()
-    call op_restr%mv_from(tmpcoo)
-
-    if (info /= psb_success_) goto 9999
-
-  end if
+  call op_prol%mv_from(coo_prol)
+  call op_restr%mv_from(coo_restr)
 
   call psb_erractionrestore(err_act)
   return
@@ -217,5 +179,20 @@ subroutine mld_saggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 9999 call psb_error_handler(err_act)
 
   return
+  
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_s_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
 
+  end subroutine check_coo
 end subroutine mld_saggrmat_nosmth_bld

mlprec/impl/aggregator/mld_saggrmat_smth_bld.f90

@@ -102,7 +102,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine mld_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_s_inner_mod, mld_protect_name => mld_saggrmat_smth_bld
@@ -112,11 +113,12 @@ subroutine mld_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
 
   ! Arguments
   type(psb_sspmat_type), intent(in)      :: a
-  type(psb_desc_type), intent(in)          :: desc_a
+  type(psb_desc_type), intent(inout)       :: desc_a
   integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
-  type(mld_sml_parms), intent(inout)    :: parms 
-  type(psb_lsspmat_type), intent(inout)  :: op_prol
-  type(psb_lsspmat_type), intent(out)    :: ac,op_restr
+  type(mld_sml_parms), intent(inout)      :: parms 
+  type(psb_sspmat_type), intent(out)      :: op_prol,ac,op_restr
+  type(psb_lsspmat_type), intent(inout)    :: t_prol
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)           :: info
 
   ! Local variables
@@ -125,9 +127,9 @@ subroutine mld_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   integer(psb_ipk_) :: inaggr, nzlp
   integer(psb_ipk_) :: ictxt, np, me
   character(len=20) :: name
-  type(psb_desc_type) :: tmp_desc
-  type(psb_ls_coo_sparse_mat) :: coo_prol, coo_restr, tmpcoo
-  type(psb_ls_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
+  type(psb_ls_coo_sparse_mat) :: tmpcoo
+  type(psb_s_coo_sparse_mat) :: coo_prol, coo_restr
+  type(psb_s_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
   real(psb_spk_), allocatable :: adiag(:)
   real(psb_spk_), allocatable :: arwsum(:)
   integer(psb_ipk_)  :: ierr(5)
@@ -176,7 +178,6 @@ subroutine mld_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
-  call op_prol%mv_to(coo_prol)
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -255,20 +256,24 @@ subroutine mld_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   call acsrf%scal(adiag,info)
   if (info /= psb_success_) goto 9999
 
+  call t_prol%mv_to(tmpcoo)
   inaggr = naggr
-  call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-  nzlp = coo_prol%get_nzeros()
-  call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-  call coo_prol%set_ncols(tmp_desc%get_local_cols())
-  call coo_prol%mv_to_fmt(csr_prol,info)  
+  call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
+  nzlp = tmpcoo%get_nzeros()
+  call desc_ac%indxmap%g2lip_ins(tmpcoo%ja(1:nzlp),info) 
+  call tmpcoo%set_ncols(desc_ac%get_local_cols())
+  call tmpcoo%mv_to_ifmt(csr_prol,info)
+
+  call psb_cdasb(desc_ac,info)
+  call psb_cd_reinit(desc_ac,info)
   !
   ! Build the smoothed prolongator using either A or Af
   !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
   ! This is always done through the variable acsrf which
-  ! is a bit less readable, butsaves space and one extra matrix copy
+  ! is a bit less readable, but saves space and one matrix copy
   ! 
   call omega_smooth(omega,acsrf)
-  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,tmp_desc,info)
+  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,desc_ac,info)
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
     goto 9999
@@ -281,9 +286,9 @@ subroutine mld_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   nzl = acsr1%get_nzeros()
   call acsr1%mv_to_coo(coo_prol,info)
   
-  call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-       & coo_prol,tmp_desc,coo_restr,info)
-  
+  call mld_ptap(acsr,desc_a,nlaggr,parms,ac,&
+       & coo_prol,desc_ac,coo_restr,info)
+
   call op_prol%mv_from(coo_prol)
   call op_restr%mv_from(coo_restr)
 
@@ -303,7 +308,7 @@ contains
   subroutine omega_smooth(omega,acsr)
     implicit none 
     real(psb_spk_),intent(in) :: omega
-    type(psb_ls_csr_sparse_mat), intent(inout) :: acsr
+    type(psb_s_csr_sparse_mat), intent(inout) :: acsr
     !
     integer(psb_lpk_) :: i,j
     do i=1,acsr%get_nrows()

mlprec/impl/aggregator/mld_z_dec_aggregator_mat_asb.f90

@@ -83,7 +83,7 @@
 !    info       -  integer, output.
 !                  Error code.
 !  
-subroutine  mld_z_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
+subroutine  mld_z_dec_aggregator_mat_asb(ag,parms,a,desc_a,&
      & ac,desc_ac, op_prol,op_restr,info)
   use psb_base_mod
   use mld_base_prec_type
@@ -93,16 +93,13 @@ subroutine  mld_z_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   type(mld_dml_parms), intent(inout)  :: parms 
   type(psb_zspmat_type), intent(in)    :: a
   type(psb_desc_type), intent(inout)     :: desc_a
-  integer(psb_lpk_), intent(inout)       :: ilaggr(:), nlaggr(:)
-  type(psb_lzspmat_type), intent(inout) :: op_prol, ac,op_restr
+  type(psb_zspmat_type), intent(inout) :: op_prol, ac,op_restr
   type(psb_desc_type), intent(inout)     :: desc_ac
   integer(psb_ipk_), intent(out)         :: info
   !
   integer(psb_ipk_)              :: ictxt, np, me
-  type(psb_lz_coo_sparse_mat)  :: lacoo, lbcoo
-  type(psb_z_coo_sparse_mat)   :: acoo
-  type(psb_lz_csr_sparse_mat)  :: acsr1
-  type(psb_zspmat_type)        :: tmp_ac
+  type(psb_lz_coo_sparse_mat)  :: tmpcoo
+  type(psb_lzspmat_type)       :: tmp_ac
   integer(psb_ipk_)              :: i_nr, i_nc, i_nl, nzl
   integer(psb_lpk_)              :: ntaggr
   integer(psb_ipk_) :: err_act, debug_level, debug_unit
@@ -117,70 +114,13 @@ subroutine  mld_z_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   ictxt = desc_a%get_context()
   call psb_info(ictxt,me,np)
 
-
-
-  ntaggr = sum(nlaggr)
-
   select case(parms%coarse_mat)
 
   case(mld_distr_mat_) 
 
-    call ac%mv_to(lbcoo)
-    nzl  = lbcoo%get_nzeros()
-    i_nl = nlaggr(me+1)
-    if (info == psb_success_) call psb_cdall(ictxt,desc_ac,info,nl=i_nl)
-    if (info == psb_success_) call psb_cdins(nzl,lbcoo%ia,lbcoo%ja,desc_ac,info)
-    if (info == psb_success_) call psb_cdasb(desc_ac,info)
-    if (info == psb_success_) call psb_glob_to_loc(lbcoo%ia(1:nzl),desc_ac,info,iact='I')
-    if (info == psb_success_) call psb_glob_to_loc(lbcoo%ja(1:nzl),desc_ac,info,iact='I')
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Creating desc_ac and converting ac')
-      goto 9999
-    end if
-    if (debug_level >= psb_debug_outer_) &
-         & write(debug_unit,*) me,' ',trim(name),&
-         & 'Assembld aux descr. distr.'
-    call ac%mv_from(lbcoo)
-    call ac%set_nrows(desc_ac%get_local_rows())
-    call ac%set_ncols(desc_ac%get_local_cols())
-    call ac%set_asb()
-
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
-      goto 9999
-    end if
-
-    if (np>1) then 
-      call op_prol%mv_to(acsr1)
-      nzl = acsr1%get_nzeros()
-      call psb_glob_to_loc(acsr1%ja(1:nzl),desc_ac,info,'I')
-      if(info /= psb_success_) then
-        call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
-        goto 9999
-      end if
-      call op_prol%mv_from(acsr1)
-    endif
-    call op_prol%set_ncols(desc_ac%get_local_cols())
-
-    if (np>1) then 
-      !call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
-      call op_restr%mv_to(lacoo)
-      nzl = lacoo%get_nzeros()
-      if (info == psb_success_) call psb_glob_to_loc(lacoo%ia(1:nzl),desc_ac,info,'I')
-      call lacoo%set_dupl(psb_dupl_add_)
-      if (info == psb_success_) call op_restr%mv_from(lacoo)
-      if (info == psb_success_) call op_restr%cscnv(info,type='csr')        
-      if(info /= psb_success_) then
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='Converting op_restr to local')
-        goto 9999
-      end if
-    end if
-    !
-    ! Clip to local rows.
-    !
-    call op_restr%set_nrows(desc_ac%get_local_rows())
+    call ac%cscnv(info,type='csr')
+    call op_prol%cscnv(info,type='csr')
+    call op_restr%cscnv(info,type='csr')
 
     if (debug_level >= psb_debug_outer_) &
          & write(debug_unit,*) me,' ',trim(name),&
@@ -188,23 +128,39 @@ subroutine  mld_z_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
 
   case(mld_repl_mat_) 
     !
+    ! We are assuming here that an z matrix
+    ! can hold all entries
     !
-    ! If we are here, it means we assume that an IPK version of the
-    ! coarse matrix can hold all indices. User beware!
-    !
+    if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then 
+      ntaggr = desc_ac%get_global_rows()
+      i_nr   = ntaggr
+    else
+      info = psb_err_internal_error_
+      call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
+      goto 9999
+    end if
+    
+    call op_prol%mv_to(tmpcoo)
+    nzl = tmpcoo%get_nzeros()
+    call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
+    call tmpcoo%set_ncols(i_nr)
+    call op_prol%mv_from(tmpcoo)
+
+    call op_restr%mv_to(tmpcoo)
+    nzl = tmpcoo%get_nzeros()
+    call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
+    call tmpcoo%set_nrows(i_nr)
+    call op_restr%mv_from(tmpcoo)
+
+
+    call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
+         & dupl=psb_dupl_add_,keeploc=.false.)
+    call tmp_ac%mv_to(tmpcoo)
+    call ac%mv_from(tmpcoo)
     
-    !
-    ! op_prol/op_restr come from par_spmm_bld with local sizes
-    ! suitable for DIST option, fix relevant sizes
-    ! 
-    call op_prol%set_ncols(ntaggr)
-    call op_restr%set_nrows(ntaggr)
     call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
     if (info == psb_success_) call psb_cdasb(desc_ac,info)
-    if (info == psb_success_) call ac%mv_to(acoo)
-    if (info == psb_success_) call tmp_ac%mv_from(acoo)
-    if (info == psb_success_) &
-         & call psb_gather(ac,tmp_ac,desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)     
+
     if (info /= psb_success_) goto 9999
 
   case default 
@@ -221,4 +177,19 @@ subroutine  mld_z_dec_aggregator_mat_asb(ag,parms,a,desc_a,ilaggr,nlaggr,&
   return
 
 
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_lz_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
 end subroutine mld_z_dec_aggregator_mat_asb

mlprec/impl/aggregator/mld_z_dec_aggregator_mat_bld.f90

@@ -133,7 +133,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !  
-subroutine  mld_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_prol,op_restr,info)
+subroutine  mld_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_z_prec_type, mld_protect_name => mld_z_dec_aggregator_mat_bld
   use mld_z_inner_mod 
@@ -144,15 +145,14 @@ subroutine  mld_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_p
   type(psb_zspmat_type), intent(in)    :: a
   type(psb_desc_type), intent(inout)     :: desc_a
   integer(psb_lpk_), intent(inout)     :: ilaggr(:), nlaggr(:)
-  type(psb_lzspmat_type), intent(inout)   :: op_prol
-  type(psb_lzspmat_type), intent(out)   :: ac,op_restr
+  type(psb_lzspmat_type), intent(inout)   :: t_prol
+  type(psb_zspmat_type), intent(out)   :: op_prol,ac,op_restr
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)       :: info
 
   ! Local variables
   character(len=20)            :: name
   integer(psb_mpk_)            :: ictxt, np, me
-  type(psb_lz_coo_sparse_mat) :: acoo, bcoo
-  type(psb_lz_csr_sparse_mat) :: acsr1
   integer(psb_lpk_)            :: nzl,ntaggr
   integer(psb_ipk_)            :: err_act
   integer(psb_ipk_)            :: debug_level, debug_unit
@@ -177,22 +177,22 @@ subroutine  mld_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,ac,op_p
   case (mld_no_smooth_) 
 
     call mld_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,&
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case(mld_smooth_prol_) 
 
     call mld_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
-  case(mld_biz_prol_) 
-
-    call mld_zaggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+!!$  case(mld_biz_prol_) 
+!!$
+!!$    call mld_zaggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
+!!$         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case(mld_min_energy_) 
 
     call mld_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
-         & parms,ac,op_prol,op_restr,info)
+         & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
 
   case default
     info = psb_err_internal_error_

mlprec/impl/aggregator/mld_z_dec_aggregator_tprol.f90

@@ -68,14 +68,14 @@
 !                  overlap.
 !    nlaggr     -  integer, dimension(:), allocatable, output
 !                  nlaggr(i) contains the aggregates held by process i.
-!    op_prol    -  type(psb_zspmat_type), output
+!    t_prol    -  type(psb_zspmat_type), output
 !               The tentative prolongator, based on ilaggr.
 !               
 !    info    -  integer, output.
 !               Error code.         
 !  
 subroutine  mld_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
-     & a,desc_a,ilaggr,nlaggr,op_prol,info)
+     & a,desc_a,ilaggr,nlaggr,t_prol,info)
   use psb_base_mod
   use mld_z_prec_type, mld_protect_name => mld_z_dec_aggregator_build_tprol
   use mld_z_inner_mod
@@ -86,7 +86,7 @@ subroutine  mld_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
   type(psb_zspmat_type), intent(in)   :: a
   type(psb_desc_type), intent(in)     :: desc_a
   integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
-  type(psb_lzspmat_type), intent(out)  :: op_prol
+  type(psb_lzspmat_type), intent(out)  :: t_prol
   integer(psb_ipk_), intent(out)      :: info
 
   ! Local variables
@@ -123,7 +123,7 @@ subroutine  mld_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
   clean_zeros = ag%do_clean_zeros
   call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
 
-  if (info==psb_success_) call mld_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
+  if (info==psb_success_) call mld_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
   if (info /= psb_success_) then
     info=psb_err_from_subroutine_
     call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')

mlprec/impl/aggregator/mld_z_map_to_tprol.f90

@@ -124,9 +124,9 @@ subroutine mld_z_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
     goto 9999
   end if
 
-  call tmpcoo%allocate(ncol,ntaggr,ncol)
+  call tmpcoo%allocate(nrow,ntaggr,ncol)
   k = 0 
-  do i=1,ncol
+  do i=1,nrow
     !
     ! Note: at this point, a value ilaggr(i)<=0
     ! tags a "singleton" row, and it has to be

mlprec/impl/aggregator/mld_z_ptap.f90

@@ -0,0 +1,689 @@
+!   
+!   
+!                             MLD2P4  Extensions
+!    
+!    (C) Copyright 2019
+!  
+!                        Salvatore Filippone  Cranfield University
+!        Pasqua D'Ambra         IAC-CNR, Naples, IT
+!   
+!    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.
+!   
+!  
+! File: mld_daggrmat_nosmth_bld.F90
+!
+!
+subroutine mld_z_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_z_inner_mod
+  use mld_z_base_aggregator_mod, mld_protect_name => mld_z_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_z_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)          :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_dml_parms), intent(inout)         :: parms 
+  type(psb_z_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_zspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_lz_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_z_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nglob, ntaggr, naggrm1, naggrp1
+  integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_fmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      call coo_prol%cp_to_coo(coo_restr,info)
+      call coo_restr%set_ncols(desc_ac%get_local_cols())
+      call coo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_z_coo_glob_transpose(coo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call coo_restr%set_nrows(desc_ac%get_local_rows())
+      call coo_restr%set_ncols(desc_ax%get_local_cols())
+!!$      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+!!$           & desc_a%get_local_cols(),desc_ax%get_local_cols(),coo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+    end block
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_coo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_z_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_z_ptap
+
+subroutine mld_z_lz_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_z_inner_mod
+  use mld_z_base_aggregator_mod !, mld_protect_name => mld_z_lz_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_z_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)          :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_dml_parms), intent(inout)         :: parms 
+  type(psb_lz_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_lzspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_lz_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_z_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
+       &  nzt, naggrm1, naggrp1, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_ifmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      type(psb_z_coo_sparse_mat) :: icoo_restr
+
+      call coo_prol%cp_to_icoo(icoo_restr,info)
+      call icoo_restr%set_ncols(desc_ac%get_local_cols())
+      call icoo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_z_coo_glob_transpose(icoo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call icoo_restr%set_nrows(desc_ac%get_local_rows())
+      call icoo_restr%set_ncols(desc_ax%get_local_cols())
+      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+           & desc_a%get_local_cols(),desc_ax%get_local_cols(),icoo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+      call coo_restr%cp_from_icoo(icoo_restr,info)
+    end block
+    call csr_restr%cp_from_lcoo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_lcoo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_lcoo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_lz_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_z_lz_ptap
+
+subroutine mld_lz_ptap(a_csr,desc_a,nlaggr,parms,ac,&
+     & coo_prol,desc_ac,coo_restr,info,desc_ax)
+  use psb_base_mod
+  use mld_z_inner_mod
+  use mld_z_base_aggregator_mod!, mld_protect_name => mld_lz_ptap
+  implicit none
+
+  ! Arguments
+  type(psb_lz_csr_sparse_mat), intent(inout) :: a_csr
+  type(psb_desc_type), intent(inout)           :: desc_a
+  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
+  type(mld_dml_parms), intent(inout)         :: parms 
+  type(psb_lz_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
+  type(psb_desc_type), intent(inout)         :: desc_ac
+  type(psb_lzspmat_type), intent(out)        :: ac
+  integer(psb_ipk_), intent(out)             :: info
+  type(psb_desc_type), intent(inout), optional :: desc_ax
+
+  ! Local variables
+  integer(psb_ipk_)  :: err_act
+  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
+  character(len=40)  :: name
+  integer(psb_ipk_)  :: ierr(5)
+  type(psb_lz_coo_sparse_mat) :: ac_coo, tmpcoo
+  type(psb_lz_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
+  integer(psb_ipk_) :: debug_level, debug_unit, naggr
+  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
+       &  nzt, naggrm1, naggrp1, i, k
+  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
+  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
+  integer(psb_ipk_), save :: idx_spspmm=-1
+
+  name='mld_ptap'
+  if(psb_get_errstatus().ne.0) return 
+  info=psb_success_
+  call psb_erractionsave(err_act)
+
+
+  ictxt = desc_a%get_context()
+  icomm = desc_a%get_mpic()
+  call psb_info(ictxt, me, np)
+  debug_unit  = psb_get_debug_unit()
+  debug_level = psb_get_debug_level()
+  nglob = desc_a%get_global_rows()
+  nrow  = desc_a%get_local_rows()
+  ncol  = desc_a%get_local_cols()
+
+  if ((do_timings).and.(idx_spspmm==-1)) &
+       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
+
+  naggr   = nlaggr(me+1)
+  ntaggr  = sum(nlaggr)
+  naggrm1 = sum(nlaggr(1:me))
+  naggrp1 = sum(nlaggr(1:me+1)) 
+  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
+
+  !
+  ! COO_PROL should arrive here with local numbering
+  !
+  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
+       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
+       & nrow,ntaggr,naggr
+
+  call coo_prol%cp_to_fmt(csr_prol,info)
+
+  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
+       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
+       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
+       & desc_ac%get_local_rows(),desc_a%get_local_cols()
+  if (debug) flush(0)
+
+  if (do_timings) call psb_tic(idx_spspmm)
+  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_ac,info)
+  if (do_timings) call psb_toc(idx_spspmm)  
+
+  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
+       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
+       & desc_ac%get_local_rows(),desc_ac%get_local_cols()
+
+  !
+  ! Ok first product done.
+
+  if (present(desc_ax)) then
+    block 
+      type(psb_z_coo_sparse_mat) :: icoo_restr
+
+      call coo_prol%cp_to_icoo(icoo_restr,info)
+      call icoo_restr%set_ncols(desc_ac%get_local_cols())
+      call icoo_restr%set_nrows(desc_a%get_local_rows())
+      call psb_z_coo_glob_transpose(icoo_restr,desc_a,info,desc_c=desc_ac,desc_rx=desc_ax)
+      call icoo_restr%set_nrows(desc_ac%get_local_rows())
+      call icoo_restr%set_ncols(desc_ax%get_local_cols())
+      write(0,*) me,' ',trim(name),' check on glob_transpose 1: ',&
+           & desc_a%get_local_cols(),desc_ax%get_local_cols(),icoo_restr%get_nzeros()
+      if (desc_a%get_local_cols()<desc_ax%get_local_cols()) then
+        write(0,*) me,' ',trim(name),' WARNING: GLOB_TRANSPOSE NEW INDICES '
+      end if
+      call coo_restr%cp_from_icoo(icoo_restr,info)
+    end block
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_ax,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+
+  else
+
+    !
+    ! Remember that RESTR must be built from PROL after halo extension,
+    ! which is done above in psb_par_spspmm
+    if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
+         & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
+    call csr_prol%mv_to_coo(coo_restr,info)
+!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
+!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
+    if (debug) call check_coo(me,trim(name)//' Check 1 (before transp) on coo_restr:',coo_restr)
+
+    call coo_restr%transp()
+    nzl = coo_restr%get_nzeros()
+    nrl = desc_ac%get_local_rows() 
+    i=0
+    !
+    ! Only keep local rows
+    !
+    do k=1, nzl
+      if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
+        i = i+1
+        coo_restr%val(i) = coo_restr%val(k)
+        coo_restr%ia(i)  = coo_restr%ia(k)
+        coo_restr%ja(i)  = coo_restr%ja(k)
+      end if
+    end do
+    call coo_restr%set_nzeros(i)
+    call coo_restr%fix(info) 
+    nzl  = coo_restr%get_nzeros()
+    call coo_restr%set_nrows(desc_ac%get_local_rows())
+    call coo_restr%set_ncols(desc_a%get_local_cols())
+    if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
+    call csr_restr%cp_from_coo(coo_restr,info)
+
+!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
+
+    if (info /= psb_success_) then 
+      call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
+      goto 9999
+    end if
+    if (debug_level >= psb_debug_outer_) &
+         & write(debug_unit,*) me,' ',trim(name),&
+         & 'starting sphalo/ rwxtd'
+
+    if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
+         & csr_restr%get_nrows(),csr_restr%get_ncols(), &
+         & desc_ac%get_local_rows(),desc_a%get_local_cols(),&
+         & acsr3%get_nrows(),acsr3%get_ncols()
+    if (do_timings) call psb_tic(idx_spspmm)      
+    call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_ac,info)
+    if (do_timings) call psb_toc(idx_spspmm)      
+    call acsr3%free()
+  end if
+
+  call psb_cdasb(desc_ac,info)
+
+  call ac_csr%set_nrows(desc_ac%get_local_rows())
+  call ac_csr%set_ncols(desc_ac%get_local_cols())
+  call ac%mv_from(ac_csr)
+  call ac%set_asb()
+
+  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
+  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
+  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
+
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
+  !call coo_restr%mv_from_ifmt(csr_restr,info)
+!!$    call coo_restr%set_nrows(desc_ac%get_local_rows())
+!!$    call coo_restr%set_ncols(desc_a%get_local_cols())
+  if (debug) call check_coo(me,trim(name)//' Check 3 on coo_restr:',coo_restr)
+
+
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),&
+       & 'Done ptap '
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_lz_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
+
+  end subroutine check_coo
+  
+end subroutine mld_lz_ptap

mlprec/impl/aggregator/mld_z_spmm_bld_inner.f90

@@ -1,390 +0,0 @@
-!   
-!   
-!                             MLD2P4  Extensions
-!    
-!    (C) Copyright 2019
-!  
-!                        Salvatore Filippone  Cranfield University
-!        Pasqua D'Ambra         IAC-CNR, Naples, IT
-!   
-!    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.
-!   
-!  
-! File: mld_daggrmat_nosmth_bld.F90
-!
-!
-subroutine mld_z_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,&
-     & coo_prol,desc_cprol,coo_restr,info)
-  use psb_base_mod
-  use mld_z_inner_mod
-  use mld_z_base_aggregator_mod, mld_protect_name => mld_z_spmm_bld_inner
-  implicit none
-
-  ! Arguments
-  type(psb_z_csr_sparse_mat), intent(inout) :: a_csr
-  type(psb_desc_type), intent(in)            :: desc_a
-  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
-  type(mld_dml_parms), intent(inout)         :: parms 
-  type(psb_lz_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
-  type(psb_desc_type), intent(inout)         :: desc_cprol
-  type(psb_lzspmat_type), intent(out)        :: ac
-  integer(psb_ipk_), intent(out)             :: info
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
-  character(len=40)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_lz_coo_sparse_mat) :: ac_coo, tmpcoo
-  type(psb_z_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
-  integer(psb_ipk_) :: debug_level, debug_unit, naggr
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
-       &  nzt, naggrm1, naggrp1, i, k
-  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
-  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
-
-  name='mld_spmm_bld_inner'
-  if(psb_get_errstatus().ne.0) return 
-  info=psb_success_
-  call psb_erractionsave(err_act)
-
-
-  ictxt = desc_a%get_context()
-  icomm = desc_a%get_mpic()
-  call psb_info(ictxt, me, np)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
-
-  naggr   = nlaggr(me+1)
-  ntaggr  = sum(nlaggr)
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1)) 
-  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
-
-  !
-  ! COO_PROL should arrive here with local numbering
-  !
-  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
-       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
-       & nrow,ntaggr,naggr
-
-  call coo_prol%cp_to_ifmt(csr_prol,info)
-
-  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
-       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
-       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols()
-  if (debug) flush(0)
-
-  if (do_timings) call psb_tic(idx_spspmm)
-  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)  
-
-  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
-       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
-       & desc_cprol%get_local_rows(),desc_cprol%get_local_cols()
-
-  !
-  ! Ok first product done.
-  !
-  ! Remember that RESTR must be built from PROL after halo extension,
-  ! which is done above in psb_par_spspmm
-  if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
-       & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
-  call csr_prol%cp_to_lcoo(coo_restr,info)
-!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
-!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
-  call coo_restr%transp()
-  nzl = coo_restr%get_nzeros()
-  call desc_cprol%l2gip(coo_restr%ia(1:nzl),info)
-  i=0
-  !
-  ! Now we have to fix this.  The only rows of the restrictor that are correct 
-  ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-  !
-  do k=1, nzl
-    if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then
-      i = i+1
-      coo_restr%val(i) = coo_restr%val(k)
-      coo_restr%ia(i)  = coo_restr%ia(k)
-      coo_restr%ja(i)  = coo_restr%ja(k)
-    end if
-  end do
-  call coo_restr%set_nzeros(i)
-  call coo_restr%fix(info)
-  call coo_restr%cp_to_coo(tmpcoo,info)
-!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
-
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
-    goto 9999
-  end if
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'starting sphalo/ rwxtd'
-  nzl    = tmpcoo%get_nzeros()    
-  call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_cprol,info,iact='I',owned=.true.)
-  call tmpcoo%clean_negidx(info)
-  nzl  = tmpcoo%get_nzeros()
-  call tmpcoo%set_nrows(desc_cprol%get_local_rows())
-  call tmpcoo%set_ncols(desc_a%get_local_cols())
-!!$    write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros()      
-  call csr_restr%mv_from_lcoo(tmpcoo,info)
-
-  if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
-       & csr_restr%get_nrows(),csr_restr%get_ncols(), &
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols(),&
-       & acsr3%get_nrows(),acsr3%get_ncols()
-  if (do_timings) call psb_tic(idx_spspmm)      
-  call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)      
-  call csr_restr%free()
-  call acsr3%free()
-  call ac_csr%mv_to_lcoo(ac_coo,info)
-  call ac_coo%fix(info)
-  nza    = ac_coo%get_nzeros()
-  if (debug) write(0,*) me,trim(name),' Fixed ac ',&
-       & ac_coo%get_nrows(),ac_coo%get_ncols(), nza
-  call desc_cprol%indxmap%l2gip(ac_coo%ia(1:nza),info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ja(1:nza),info)
-  call ac_coo%set_nrows(ntaggr)
-  call ac_coo%set_ncols(ntaggr)
-  if (debug) write(0,*)  me,' ',trim(name),' Before mv_from',psb_get_errstatus()
-  if (info == 0) call ac%mv_from(ac_coo)
-  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
-  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
-  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
-
-  nza = coo_prol%get_nzeros()
-  call desc_cprol%indxmap%l2gip(coo_prol%ja(1:nza),info)
-  
-  if (debug) then
-    write(0,*) me,' ',trim(name),' Checkpoint at exit'
-    call psb_barrier(ictxt)
-    write(0,*) me,' ',trim(name),' Checkpoint through'
-  end if
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done spmm_bld_inner '
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-  
-end subroutine mld_z_spmm_bld_inner
-
-subroutine mld_lz_spmm_bld_inner(a_csr,desc_a,nlaggr,parms,ac,&
-     & coo_prol,desc_cprol,coo_restr,info)
-  use psb_base_mod
-  use mld_z_inner_mod
-  use mld_z_base_aggregator_mod, mld_protect_name => mld_lz_spmm_bld_inner
-  implicit none
-
-  ! Arguments
-  type(psb_lz_csr_sparse_mat), intent(inout) :: a_csr
-  type(psb_desc_type), intent(in)            :: desc_a
-  integer(psb_lpk_), intent(inout)           :: nlaggr(:)
-  type(mld_dml_parms), intent(inout)         :: parms 
-  type(psb_lz_coo_sparse_mat), intent(inout)  :: coo_prol, coo_restr
-  type(psb_desc_type), intent(inout)         :: desc_cprol
-  type(psb_lzspmat_type), intent(out)        :: ac
-  integer(psb_ipk_), intent(out)             :: info
-
-  ! Local variables
-  integer(psb_ipk_)  :: err_act
-  integer(psb_ipk_)  :: ictxt,np,me, icomm, ndx, minfo
-  character(len=40)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_lz_coo_sparse_mat) :: ac_coo, tmpcoo
-  type(psb_lz_csr_sparse_mat) :: acsr3, csr_prol, ac_csr, csr_restr
-  integer(psb_ipk_) :: debug_level, debug_unit, naggr
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
-       &  nzt, naggrm1, naggrp1, i, k
-  integer(psb_lpk_) ::  nrsave, ncsave, nzsave, nza
-  logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.  
-  integer(psb_ipk_), save :: idx_spspmm=-1
-
-  name='mld_spmm_bld_inner'
-  if(psb_get_errstatus().ne.0) return 
-  info=psb_success_
-  call psb_erractionsave(err_act)
-
-
-  ictxt = desc_a%get_context()
-  icomm = desc_a%get_mpic()
-  call psb_info(ictxt, me, np)
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  if ((do_timings).and.(idx_spspmm==-1)) &
-       & idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
-
-  naggr   = nlaggr(me+1)
-  ntaggr  = sum(nlaggr)
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1)) 
-  !write(0,*)me,' ',name,' input sizes',nlaggr(:),':',naggr
-
-  !
-  ! Here COO_PROL should be with GLOBAL indices on the cols
-  ! and LOCAL indices on the rows. 
-  !
-  if (debug) write(0,*)  me,' ',trim(name),' Size check on entry New: ',&
-       & coo_prol%get_fmt(),coo_prol%get_nrows(),coo_prol%get_ncols(),coo_prol%get_nzeros(),&
-       & nrow,ntaggr,naggr
-
-  call coo_prol%cp_to_fmt(csr_prol,info)
-
-  if (debug) write(0,*) me,trim(name),' Product AxPROL ',&
-       & a_csr%get_nrows(),a_csr%get_ncols(), csr_prol%get_nrows(), &
-       & desc_a%get_local_rows(),desc_a%get_local_cols(),&
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols()
-  if (debug) flush(0)
-
-  if (do_timings) call psb_tic(idx_spspmm)
-  call psb_par_spspmm(a_csr,desc_a,csr_prol,acsr3,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)  
-
-  if (debug) write(0,*) me,trim(name),' Done AxPROL ',&
-       & acsr3%get_nrows(),acsr3%get_ncols(), acsr3%get_nzeros(),&
-       & desc_cprol%get_local_rows(),desc_cprol%get_local_cols()
-
-  !
-  ! Ok first product done.
-  !
-  ! Remember that RESTR must be built from PROL after halo extension,
-  ! which is done above in psb_par_spspmm
-  if (debug) write(0,*)me,' ',name,' No inp_restr, transposing prol ',&
-       & csr_prol%get_nrows(),csr_prol%get_ncols(),csr_prol%get_nzeros()
-  call csr_prol%cp_to_fmt(coo_restr,info)
-!!$      write(0,*)me,' ',name,' new into transposition ',coo_restr%get_nrows(),&
-!!$           & coo_restr%get_ncols(),coo_restr%get_nzeros()
-  call coo_restr%transp()
-  nzl = coo_restr%get_nzeros()
-  call desc_cprol%l2gip(coo_restr%ia(1:nzl),info)
-  i=0
-  !
-  ! Now we have to fix this.  The only rows of the restrictor that are correct 
-  ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-  !
-  do k=1, nzl
-    if ((naggrm1 < coo_restr%ia(k)) .and.(coo_restr%ia(k) <= naggrp1)) then
-      i = i+1
-      coo_restr%val(i) = coo_restr%val(k)
-      coo_restr%ia(i)  = coo_restr%ia(k)
-      coo_restr%ja(i)  = coo_restr%ja(k)
-    end if
-  end do
-  call coo_restr%set_nzeros(i)
-  call coo_restr%fix(info)
-  call coo_restr%cp_to_coo(tmpcoo,info)
-!!$      write(0,*)me,' ',name,' after transposition ',coo_restr%get_nrows(),coo_restr%get_ncols(),coo_restr%get_nzeros()
-
-  if (info /= psb_success_) then 
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
-    goto 9999
-  end if
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'starting sphalo/ rwxtd'
-  nzl    = tmpcoo%get_nzeros()    
-  call psb_glob_to_loc(tmpcoo%ia(1:nzl),desc_cprol,info,iact='I',owned=.true.)
-  call tmpcoo%clean_negidx(info)
-  nzl  = tmpcoo%get_nzeros()
-  call tmpcoo%set_nrows(desc_cprol%get_local_rows())
-  call tmpcoo%set_ncols(desc_a%get_local_cols())
-!!$    write(0,*)me,' ',name,' after G2L on rows ',tmpcoo%get_nrows(),tmpcoo%get_ncols(),tmpcoo%get_nzeros()      
-  call csr_restr%mv_from_coo(tmpcoo,info)
-
-  if (debug) write(0,*) me,trim(name),' Product RESTRxAP ',&
-       & csr_restr%get_nrows(),csr_restr%get_ncols(), &
-       & desc_cprol%get_local_rows(),desc_a%get_local_cols(),&
-       & acsr3%get_nrows(),acsr3%get_ncols()
-  if (do_timings) call psb_tic(idx_spspmm)      
-  call psb_par_spspmm(csr_restr,desc_a,acsr3,ac_csr,desc_cprol,info)
-  if (do_timings) call psb_toc(idx_spspmm)      
-  call csr_restr%free()
-  call ac_csr%mv_to_coo(ac_coo,info)
-  nza    = ac_coo%get_nzeros()
-  if (debug) write(0,*) me,trim(name),' Fixing ac ',&
-       & ac_coo%get_nrows(),ac_coo%get_ncols(), nza
-  call ac_coo%fix(info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ia(1:nza),info)
-  call desc_cprol%indxmap%l2gip(ac_coo%ja(1:nza),info)
-  call ac_coo%set_nrows(ntaggr)
-  call ac_coo%set_ncols(ntaggr)
-  if (debug) write(0,*)  me,' ',trim(name),' Before mv_from',psb_get_errstatus()
-  if (info == 0) call ac%mv_from(ac_coo)
-  if (debug) write(0,*)  me,' ',trim(name),' After  mv_from',psb_get_errstatus()
-  if (debug) write(0,*)  me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
-  ! write(0,*)  me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
-
-  nza = coo_prol%get_nzeros()
-  call desc_cprol%indxmap%l2gip(coo_prol%ja(1:nza),info)
-  
-  if (debug) then
-    write(0,*) me,' ',trim(name),' Checkpoint at exit'
-    call psb_barrier(ictxt)
-    write(0,*) me,' ',trim(name),' Checkpoint through'
-  end if
-
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done spmm_bld_inner '
-
-  call psb_erractionrestore(err_act)
-  return
-
-9999 call psb_error_handler(err_act)
-
-  return
-  
-end subroutine mld_lz_spmm_bld_inner

mlprec/impl/aggregator/mld_zaggrmat_biz_bld.f90

@@ -1,300 +0,0 @@
-!   
-!   
-!                             MLD2P4  version 2.2
-!    MultiLevel Domain Decomposition Parallel Preconditioners Package
-!               based on PSBLAS (Parallel Sparse BLAS version 3.5)
-!    
-!    (C) Copyright 2008-2018 
-!  
-!        Salvatore Filippone  
-!        Pasqua D'Ambra   
-!        Daniela di Serafino   
-!   
-!    Redistribution and use in source and binary forms, with or without
-!    modification, are permitted provided that the following conditions
-!    are met:
-!      1. Redistributions of source code must retain the above copyright
-!         notice, this list of conditions and the following disclaimer.
-!      2. Redistributions in binary form must reproduce the above copyright
-!         notice, this list of conditions, and the following disclaimer in the
-!         documentation and/or other materials provided with the distribution.
-!      3. The name of the 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.
-!   
-!  
-! File: mld_zaggrmat_biz_bld.F90
-!
-! Subroutine: mld_zaggrmat_biz_bld
-! Version:    complex
-!
-!  This routine builds a coarse-level matrix A_C from a fine-level matrix A
-!  by using the Galerkin approach, i.e.
-!
-!                               A_C = P_C^T A P_C,
-!
-!  where P_C is a prolongator from the coarse level to the fine one.
-! 
-!  This routine builds A_C according to a "bizarre" aggregation algorithm,
-!  using a "naive" prolongator proposed by the authors of MLD2P4. However, this
-!  prolongator still requires additional analysis and testing and its use is not
-!  recommended.
-!
-!  The coarse-level matrix A_C is distributed among the parallel processes or
-!  replicated on each of them, according to the value of p%parms%coarse_mat,
-!  specified by the user through mld_zprecinit and mld_zprecset.
-!  On output from this routine the entries of AC, op_prol, op_restr
-!  are still in "global numbering" mode; this is fixed in the calling routine
-!  mld_z_lev_aggrmat_bld.
-!
-! Arguments:
-!    a          -  type(psb_zspmat_type), input.     
-!                  The sparse matrix structure containing the local part of
-!                  the fine-level matrix.
-!    desc_a     -  type(psb_desc_type), input.
-!                  The communication descriptor of the fine-level matrix.
-!    p          -  type(mld_z_onelev_type), input/output.
-!                  The 'one-level' data structure that will contain the local
-!                  part of the matrix to be built as well as the information 
-!                  concerning the prolongator and its transpose.
-!    ilaggr     -  integer, dimension(:), allocatable.
-!                  The mapping between the row indices of the coarse-level
-!                  matrix and the row indices of the fine-level matrix.
-!                  ilaggr(i)=j means that node i in the adjacency graph
-!                  of the fine-level matrix is mapped onto node j in the
-!                  adjacency graph of the coarse-level matrix.
-!    nlaggr     -  integer, dimension(:), allocatable.
-!                  nlaggr(i) contains the aggregates held by process i.
-!    info       -  integer, output.
-!                  Error code.
-!
-subroutine mld_zaggrmat_biz_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
-  use psb_base_mod
-  use mld_base_prec_type
-  use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_biz_bld
-  use mld_z_base_aggregator_mod
-  
-  implicit none
-
-  ! Arguments
-  type(psb_zspmat_type), intent(in)      :: a
-  type(psb_desc_type), intent(in)          :: desc_a
-  integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
-  type(mld_dml_parms), intent(inout)    :: parms 
-  type(psb_lzspmat_type), intent(inout)  :: op_prol
-  type(psb_lzspmat_type), intent(out)    :: ac,op_restr
-  integer(psb_ipk_), intent(out)           :: info
-
-  ! Local variables
-  integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
-       & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
-  integer(psb_ipk_) :: inaggr, nzlp, inrow
-  integer(psb_ipk_) :: ictxt, np, me
-  character(len=20) :: name
-  type(psb_desc_type) :: tmp_desc
-  type(psb_z_coo_sparse_mat)  :: icoo
-  type(psb_lz_coo_sparse_mat) :: coo_prol, coo_restr, tmpcoo
-  type(psb_lz_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
-  complex(psb_dpk_), allocatable :: adiag(:)
-  real(psb_dpk_), allocatable :: arwsum(:)
-  integer(psb_ipk_)  :: ierr(5)
-  logical            :: filter_mat
-  integer(psb_ipk_)            :: debug_level, debug_unit, err_act
-  integer(psb_ipk_), parameter :: ncmax=16
-  real(psb_dpk_)     :: anorm, omega, tmp, dg, theta
-  logical, parameter :: debug_new=.false.
-  character(len=80) :: filename
-
-  name='mld_aggrmat_biz_bld'
-  info=psb_success_
-  call psb_erractionsave(err_act)
-  if (psb_errstatus_fatal()) then
-    info = psb_err_internal_error_; goto 9999
-  end if
-  debug_unit  = psb_get_debug_unit()
-  debug_level = psb_get_debug_level()
-
-  ictxt = desc_a%get_context()
-
-  call psb_info(ictxt, me, np)
-
-  nglob = desc_a%get_global_rows()
-  nrow  = desc_a%get_local_rows()
-  ncol  = desc_a%get_local_cols()
-
-  theta = parms%aggr_thresh
-
-  naggr  = nlaggr(me+1)
-  ntaggr = sum(nlaggr)
-
-  naggrm1 = sum(nlaggr(1:me))
-  naggrp1 = sum(nlaggr(1:me+1))
-  filter_mat = (parms%aggr_filter == mld_filter_mat_)
-
-  !
-  ! naggr: number of local aggregates
-  ! nrow: local rows. 
-  ! 
-
-  ! Get the diagonal D
-  adiag = a%get_diag(info)
-  if (info == psb_success_) &
-       & call psb_realloc(ncol,adiag,info)
-  if (info == psb_success_) &
-       & call psb_halo(adiag,desc_a,info)
-  if (info == psb_success_) call a%csclip(icoo,info,jmax=a%get_nrows())
-  call icoo%mv_to_lfmt(acsr,info)
-  call op_prol%mv_to(coo_prol)
-
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
-    goto 9999
-  end if
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & ' Initial copies done.'
-
-  call acsr%cp_to_fmt(acsrf,info)
-
-
-  if (filter_mat) then
-    !
-    ! Build the filtered matrix Af from A
-    ! 
-
-    do i=1, nrow
-      tmp = zzero
-      jd  = -1 
-      do j=acsrf%irp(i),acsrf%irp(i+1)-1
-        if (acsrf%ja(j) == i) jd = j 
-        if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
-          tmp=tmp+acsrf%val(j)
-          acsrf%val(j)=zzero
-        endif
-
-      enddo
-      if (jd == -1) then 
-        write(0,*) 'Wrong input: we need the diagonal!!!!', i
-      else
-        acsrf%val(jd)=acsrf%val(jd)-tmp
-      end if
-    enddo
-    ! Take out zeroed terms 
-    call acsrf%clean_zeros(info)
-  end if
-
-
-  do i=1,size(adiag)
-    if (adiag(i) /= zzero) then
-      adiag(i) = zone / adiag(i)
-    else
-      adiag(i) = zone
-    end if
-  end do
-
-  if (parms%aggr_omega_alg == mld_eig_est_) then 
-
-    if (parms%aggr_eig == mld_max_norm_) then 
-      allocate(arwsum(nrow))
-      call acsr%arwsum(arwsum)      
-      anorm = maxval(abs(adiag(1:nrow)*arwsum(1:nrow)))
-      call psb_amx(ictxt,anorm)
-      omega = 4.d0/(3.d0*anorm)
-      parms%aggr_omega_val = omega 
-
-    else 
-      info = psb_err_internal_error_
-      call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
-      goto 9999
-    end if
-
-  else if (parms%aggr_omega_alg == mld_user_choice_) then 
-
-    omega = parms%aggr_omega_val 
-
-  else if (parms%aggr_omega_alg /= mld_user_choice_) then 
-    info = psb_err_internal_error_
-    call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
-    goto 9999
-  end if
-
-  
-  call acsrf%scal(adiag,info)
-  if (info /= psb_success_) goto 9999
-
-  inaggr = naggr
-  call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-  nzlp = coo_prol%get_nzeros()
-  call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-  call coo_prol%set_ncols(tmp_desc%get_local_cols())
-  call coo_prol%mv_to_fmt(csr_prol,info)  
-  !
-  ! Build the smoothed prolongator using either A or Af
-  !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
-  ! This is always done through the variable acsrf which
-  ! is a bit less readable, butsaves space and one extra matrix copy
-  ! 
-  call omega_smooth(omega,acsrf)
-  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,tmp_desc,info)
-  if(info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
-    goto 9999
-  end if
-
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done SPSPMM 1'
-  nzl = acsr1%get_nzeros()
-  call acsr1%mv_to_coo(coo_prol,info)
-  
-  call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-       & coo_prol,tmp_desc,coo_restr,info)
-  
-  call op_prol%mv_from(coo_prol)
-  call op_restr%mv_from(coo_restr)
-
-  if (debug_level >= psb_debug_outer_) &
-       & write(debug_unit,*) me,' ',trim(name),&
-       & 'Done smooth_aggregate '
-  call psb_erractionrestore(err_act)
-  return
-
-9999 continue
-  call psb_errpush(info,name)
-  call psb_error_handler(err_act)
-  return
-
-contains
-
-  subroutine omega_smooth(omega,acsr)
-    implicit none 
-    real(psb_dpk_),intent(in) :: omega
-    type(psb_lz_csr_sparse_mat), intent(inout) :: acsr
-    !
-    integer(psb_lpk_) :: i,j
-    do i=1,acsr%get_nrows()
-      do j=acsr%irp(i),acsr%irp(i+1)-1
-        if (acsr%ja(j) == i) then 
-          acsr%val(j) = zone - omega*acsr%val(j) 
-        else
-          acsr%val(j) = - omega*acsr%val(j) 
-        end if
-      end do
-    end do
-  end subroutine omega_smooth
-
-end subroutine mld_zaggrmat_biz_bld

mlprec/impl/aggregator/mld_zaggrmat_minnrg_bld.f90

@@ -104,7 +104,8 @@
 !                  Error code.
 !
 !
-subroutine mld_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_minnrg_bld
@@ -113,11 +114,12 @@ subroutine mld_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 
   ! Arguments
   type(psb_zspmat_type), intent(in)           :: a
-  type(psb_desc_type), intent(in)               :: desc_a
+  type(psb_desc_type), intent(inout)            :: desc_a
   integer(psb_lpk_), intent(inout)              :: ilaggr(:), nlaggr(:)
   type(mld_dml_parms), intent(inout)         :: parms 
   type(psb_lzspmat_type), intent(inout)       :: op_prol
   type(psb_lzspmat_type), intent(out)         :: ac,op_restr
+  type(psb_desc_type), intent(inout)            :: desc_ac
   integer(psb_ipk_), intent(out)                :: info
 
   ! Local variables

mlprec/impl/aggregator/mld_zaggrmat_nosmth_bld.f90

@@ -96,7 +96,8 @@
 !                  Error code.
 !
 !
-subroutine mld_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_nosmth_bld
@@ -105,26 +106,26 @@ subroutine mld_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 
   ! Arguments
   type(psb_zspmat_type), intent(in)        :: a
-  type(psb_desc_type), intent(in)            :: desc_a
+  type(psb_desc_type), intent(inout)         :: desc_a
   integer(psb_lpk_), intent(inout)           :: ilaggr(:), nlaggr(:)
   type(mld_dml_parms), intent(inout)      :: parms 
-  type(psb_lzspmat_type), intent(inout)    :: op_prol
-  type(psb_lzspmat_type), intent(out)      :: ac,op_restr
+  type(psb_zspmat_type), intent(inout)       :: op_prol,ac,op_restr
+  type(psb_lzspmat_type), intent(inout)    :: t_prol
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)             :: info
 
   ! Local variables
   integer(psb_ipk_)  :: err_act
   integer(psb_ipk_)  :: ictxt, np, me, icomm,  minfo
   character(len=20)  :: name
-  integer(psb_ipk_)  :: ierr(5)
-  type(psb_lzspmat_type)      :: la 
-  type(psb_lz_coo_sparse_mat) :: ac_coo, tmpcoo, coo_prol, coo_restr
-  type(psb_lz_csr_sparse_mat) :: acsr1, acsr2, acsr
-  type(psb_desc_type) :: tmp_desc
+  type(psb_lz_coo_sparse_mat) :: lcoo_prol
+  type(psb_z_coo_sparse_mat) :: coo_prol, coo_restr
+  type(psb_z_csr_sparse_mat) :: acsr
   integer(psb_ipk_) :: debug_level, debug_unit
   integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
        & naggr, nzt, naggrm1, naggrp1, i, k
   integer(psb_ipk_) :: inaggr, nzlp
+  logical, parameter :: debug = .false.
 
   name = 'mld_aggrmat_nosmth_bld'
   info = psb_success_
@@ -145,71 +146,32 @@ subroutine mld_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
   naggrm1 = sum(nlaggr(1:me))
   naggrp1 = sum(nlaggr(1:me+1))
 
-  if (.false.) then
-    !
-    ! If we ever want to switch to explicit product when building this..
-    !
-    call a%cp_to(acsr)
-    call op_prol%mv_to(coo_prol)
-    inaggr = naggr
-    call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-    nzlp = coo_prol%get_nzeros()
-    call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-    call coo_prol%set_ncols(tmp_desc%get_local_cols())
-    call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-         & coo_prol,tmp_desc,coo_restr,info)
+  call a%cp_to(acsr)
+  call t_prol%mv_to(lcoo_prol)
+  inaggr = naggr
+  call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
+  nzlp = lcoo_prol%get_nzeros()
+  call desc_ac%indxmap%g2lip_ins(lcoo_prol%ja(1:nzlp),info) 
+  call lcoo_prol%set_ncols(desc_ac%get_local_cols())
+  call lcoo_prol%cp_to_icoo(coo_prol,info)
+  
+  if (debug) call check_coo(me,trim(name)//' Check 1 on  coo_prol:',coo_prol)
 
-    call op_prol%mv_from(coo_prol)
-    call op_restr%mv_from(coo_restr)
+  call psb_cdasb(desc_ac,info)
+  call psb_cd_reinit(desc_ac,info)
 
+  call mld_ptap(acsr,desc_a,nlaggr,parms,ac,&
+       & coo_prol,desc_ac,coo_restr,info)
 
-  else
-    
-    call a%cp_to(ac_coo)
-    nzt = ac_coo%get_nzeros()
-    k   = 0
-    do i = 1, nzt 
-      k = k + 1 
-      ac_coo%ia(k)  = ilaggr(ac_coo%ia(i))
-      ac_coo%ja(k)  = ilaggr(ac_coo%ja(i))
-      ac_coo%val(k) = ac_coo%val(i)
-      ! At this point, there may be negative entries,
-      ! because that's how ILAGGR marks singletons
-      ! If this is the case, roll back K
-      if ((ac_coo%ia(k)<=0).or.(ac_coo%ja(k)<=0)) k = k-1      
-    enddo
-    call ac_coo%set_nrows(naggr)
-    call ac_coo%set_ncols(naggr)
-    call ac_coo%set_nzeros(k)
-    call ac_coo%set_dupl(psb_dupl_add_)
-    call ac_coo%fix(info)
-    call ac_coo%trim()
-    call ac%mv_from(ac_coo) 
+  call coo_restr%set_nrows(desc_ac%get_local_rows())
+  call coo_restr%set_ncols(desc_a%get_local_cols())
+  call coo_prol%set_nrows(desc_a%get_local_rows())
+  call coo_prol%set_ncols(desc_ac%get_local_cols())
 
-    call op_prol%cp_to(tmpcoo)
+  if (debug) call check_coo(me,trim(name)//' Check 1 on coo_restr:',coo_restr)
 
-    call tmpcoo%transp()
-    !
-    ! Now we have to fix this.  The only rows of tmpcoo/op_restr that are correct 
-    ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
-    !
-    nzl = tmpcoo%get_nzeros()
-    i   = 0
-    do k = 1, nzl
-      if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
-        i = i+1
-        tmpcoo%val(i) = tmpcoo%val(k)
-        tmpcoo%ia(i)  = tmpcoo%ia(k)
-        tmpcoo%ja(i)  = tmpcoo%ja(k)
-      end if
-    end do
-    call tmpcoo%set_nzeros(i)
-    call tmpcoo%trim()
-    call op_restr%mv_from(tmpcoo)
-
-    if (info /= psb_success_) goto 9999
-
-  end if
+  call op_prol%mv_from(coo_prol)
+  call op_restr%mv_from(coo_restr)
 
   call psb_erractionrestore(err_act)
   return
@@ -217,5 +179,20 @@ subroutine mld_zaggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
 9999 call psb_error_handler(err_act)
 
   return
+  
+contains
+  subroutine check_coo(me,string,coo)
+    implicit none
+    integer(psb_ipk_) :: me
+    type(psb_z_coo_sparse_mat) :: coo
+    character(len=*) :: string
+    integer(psb_lpk_) :: nr,nc,nz
+    nr = coo%get_nrows()
+    nc = coo%get_ncols()
+    nz = coo%get_nzeros()
+    write(0,*) me,string,nr,nc,&
+         & minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
+         & minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
 
+  end subroutine check_coo
 end subroutine mld_zaggrmat_nosmth_bld

mlprec/impl/aggregator/mld_zaggrmat_smth_bld.f90

@@ -102,7 +102,8 @@
 !    info       -  integer, output.
 !                  Error code.
 !
-subroutine mld_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
+subroutine mld_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
+     & ac,desc_ac,op_prol,op_restr,t_prol,info)
   use psb_base_mod
   use mld_base_prec_type
   use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_smth_bld
@@ -112,11 +113,12 @@ subroutine mld_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
 
   ! Arguments
   type(psb_zspmat_type), intent(in)      :: a
-  type(psb_desc_type), intent(in)          :: desc_a
+  type(psb_desc_type), intent(inout)       :: desc_a
   integer(psb_lpk_), intent(inout)         :: ilaggr(:), nlaggr(:)
-  type(mld_dml_parms), intent(inout)    :: parms 
-  type(psb_lzspmat_type), intent(inout)  :: op_prol
-  type(psb_lzspmat_type), intent(out)    :: ac,op_restr
+  type(mld_dml_parms), intent(inout)      :: parms 
+  type(psb_zspmat_type), intent(out)      :: op_prol,ac,op_restr
+  type(psb_lzspmat_type), intent(inout)    :: t_prol
+  type(psb_desc_type), intent(inout)       :: desc_ac
   integer(psb_ipk_), intent(out)           :: info
 
   ! Local variables
@@ -125,9 +127,9 @@ subroutine mld_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   integer(psb_ipk_) :: inaggr, nzlp
   integer(psb_ipk_) :: ictxt, np, me
   character(len=20) :: name
-  type(psb_desc_type) :: tmp_desc
-  type(psb_lz_coo_sparse_mat) :: coo_prol, coo_restr, tmpcoo
-  type(psb_lz_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
+  type(psb_lz_coo_sparse_mat) :: tmpcoo
+  type(psb_z_coo_sparse_mat) :: coo_prol, coo_restr
+  type(psb_z_csr_sparse_mat) :: acsr1,  acsrf, csr_prol, acsr
   complex(psb_dpk_), allocatable :: adiag(:)
   real(psb_dpk_), allocatable :: arwsum(:)
   integer(psb_ipk_)  :: ierr(5)
@@ -176,7 +178,6 @@ subroutine mld_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   if (info == psb_success_) &
        & call psb_halo(adiag,desc_a,info)
   if (info == psb_success_) call a%cp_to(acsr)
-  call op_prol%mv_to(coo_prol)
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -255,20 +256,24 @@ subroutine mld_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   call acsrf%scal(adiag,info)
   if (info /= psb_success_) goto 9999
 
+  call t_prol%mv_to(tmpcoo)
   inaggr = naggr
-  call psb_cdall(ictxt,tmp_desc,info,nl=inaggr)
-  nzlp = coo_prol%get_nzeros()
-  call tmp_desc%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info) 
-  call coo_prol%set_ncols(tmp_desc%get_local_cols())
-  call coo_prol%mv_to_fmt(csr_prol,info)  
+  call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
+  nzlp = tmpcoo%get_nzeros()
+  call desc_ac%indxmap%g2lip_ins(tmpcoo%ja(1:nzlp),info) 
+  call tmpcoo%set_ncols(desc_ac%get_local_cols())
+  call tmpcoo%mv_to_ifmt(csr_prol,info)
+
+  call psb_cdasb(desc_ac,info)
+  call psb_cd_reinit(desc_ac,info)
   !
   ! Build the smoothed prolongator using either A or Af
   !    acsr1 = (I-w*D*A) Prol      acsr1 = (I-w*D*Af) Prol 
   ! This is always done through the variable acsrf which
-  ! is a bit less readable, butsaves space and one extra matrix copy
+  ! is a bit less readable, but saves space and one matrix copy
   ! 
   call omega_smooth(omega,acsrf)
-  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,tmp_desc,info)
+  call psb_par_spspmm(acsrf,desc_a,csr_prol,acsr1,desc_ac,info)
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
     goto 9999
@@ -281,9 +286,9 @@ subroutine mld_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
   nzl = acsr1%get_nzeros()
   call acsr1%mv_to_coo(coo_prol,info)
   
-  call mld_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
-       & coo_prol,tmp_desc,coo_restr,info)
-  
+  call mld_ptap(acsr,desc_a,nlaggr,parms,ac,&
+       & coo_prol,desc_ac,coo_restr,info)
+
   call op_prol%mv_from(coo_prol)
   call op_restr%mv_from(coo_restr)
 
@@ -303,7 +308,7 @@ contains
   subroutine omega_smooth(omega,acsr)
     implicit none 
     real(psb_dpk_),intent(in) :: omega
-    type(psb_lz_csr_sparse_mat), intent(inout) :: acsr
+    type(psb_z_csr_sparse_mat), intent(inout) :: acsr
     !
     integer(psb_lpk_) :: i,j
     do i=1,acsr%get_nrows()

mlprec/impl/level/mld_c_base_onelev_csetc.F90

@@ -69,15 +69,16 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos,idx)
   integer(psb_ipk_)  :: ipos_, err_act
   character(len=20) :: name='c_base_onelev_csetc'
   integer(psb_ipk_) :: ival 
-  type(mld_c_base_smoother_type)  :: mld_c_base_smoother_mold
-  type(mld_c_jac_smoother_type)   ::  mld_c_jac_smoother_mold
-  type(mld_c_as_smoother_type)    ::  mld_c_as_smoother_mold
-  type(mld_c_diag_solver_type)    ::  mld_c_diag_solver_mold
-  type(mld_c_l1_diag_solver_type) ::  mld_c_l1_diag_solver_mold
-  type(mld_c_ilu_solver_type)     ::  mld_c_ilu_solver_mold
-  type(mld_c_id_solver_type)      ::  mld_c_id_solver_mold
-  type(mld_c_gs_solver_type)      ::  mld_c_gs_solver_mold
-  type(mld_c_bwgs_solver_type)    ::  mld_c_bwgs_solver_mold
+  type(mld_c_base_smoother_type)   :: mld_c_base_smoother_mold
+  type(mld_c_jac_smoother_type)    ::  mld_c_jac_smoother_mold
+  type(mld_c_l1_jac_smoother_type) ::  mld_c_l1_jac_smoother_mold
+  type(mld_c_as_smoother_type)     ::  mld_c_as_smoother_mold
+  type(mld_c_diag_solver_type)     ::  mld_c_diag_solver_mold
+  type(mld_c_l1_diag_solver_type)  ::  mld_c_l1_diag_solver_mold
+  type(mld_c_ilu_solver_type)      ::  mld_c_ilu_solver_mold
+  type(mld_c_id_solver_type)       ::  mld_c_id_solver_mold
+  type(mld_c_gs_solver_type)       ::  mld_c_gs_solver_mold
+  type(mld_c_bwgs_solver_type)     ::  mld_c_bwgs_solver_mold
 #if defined(HAVE_SLU_)
   type(mld_c_slu_solver_type)   ::  mld_c_slu_solver_mold
 #endif
@@ -124,16 +125,41 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos,idx)
     case ('BJAC')
       call lv%set(mld_c_jac_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
+      
+    case ('L1-BJAC')
+      call lv%set(mld_c_l1_jac_smoother_mold,info,pos=pos)
+      if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
 
     case ('AS')
       call lv%set(mld_c_as_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
 
+    case ('GS','FWGS')
+      call lv%set(mld_c_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_c_gs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+    case ('BWGS')
+      call lv%set(mld_c_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_c_bwgs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
     case ('FBGS')
       call lv%set(mld_c_jac_smoother_mold,info,pos='pre')
       if (info == 0) call lv%set(mld_c_gs_solver_mold,info,pos='pre')
       call lv%set(mld_c_jac_smoother_mold,info,pos='post')
       if (info == 0) call lv%set(mld_c_bwgs_solver_mold,info,pos='post')
+    case ('L1-GS','L1-FWGS')
+      call lv%set(mld_c_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_c_gs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+    case ('L1-BWGS')
+      call lv%set(mld_c_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_c_bwgs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)      
+    case ('L1-FBGS')
+      call lv%set(mld_c_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_c_gs_solver_mold,info,pos='pre')
+      call lv%set(mld_c_l1_jac_smoother_mold,info,pos='post')
+      if (info == 0) call lv%set(mld_c_bwgs_solver_mold,info,pos='post')
       
     case default
       !

mlprec/impl/level/mld_c_base_onelev_cseti.F90

@@ -68,15 +68,16 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx)
   ! Local 
   integer(psb_ipk_)  :: ipos_, err_act
   character(len=20) :: name='c_base_onelev_cseti'
-  type(mld_c_base_smoother_type)  :: mld_c_base_smoother_mold
-  type(mld_c_jac_smoother_type)   ::  mld_c_jac_smoother_mold
-  type(mld_c_as_smoother_type)    ::  mld_c_as_smoother_mold
-  type(mld_c_diag_solver_type)    ::  mld_c_diag_solver_mold
-  type(mld_c_l1_diag_solver_type) ::  mld_c_l1_diag_solver_mold
-  type(mld_c_ilu_solver_type)     ::  mld_c_ilu_solver_mold
-  type(mld_c_id_solver_type)      ::  mld_c_id_solver_mold
-  type(mld_c_gs_solver_type)      ::  mld_c_gs_solver_mold
-  type(mld_c_bwgs_solver_type)    ::  mld_c_bwgs_solver_mold
+  type(mld_c_base_smoother_type)   :: mld_c_base_smoother_mold
+  type(mld_c_jac_smoother_type)    ::  mld_c_jac_smoother_mold
+  type(mld_c_l1_jac_smoother_type) ::  mld_c_l1_jac_smoother_mold
+  type(mld_c_as_smoother_type)     ::  mld_c_as_smoother_mold
+  type(mld_c_diag_solver_type)     ::  mld_c_diag_solver_mold
+  type(mld_c_l1_diag_solver_type)  ::  mld_c_l1_diag_solver_mold
+  type(mld_c_ilu_solver_type)      ::  mld_c_ilu_solver_mold
+  type(mld_c_id_solver_type)       ::  mld_c_id_solver_mold
+  type(mld_c_gs_solver_type)       ::  mld_c_gs_solver_mold
+  type(mld_c_bwgs_solver_type)     ::  mld_c_bwgs_solver_mold
 #if defined(HAVE_SLU_)
   type(mld_c_slu_solver_type)   ::  mld_c_slu_solver_mold
 #endif
@@ -118,6 +119,10 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx)
     case (mld_bjac_)
       call lv%set(mld_c_jac_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
+      
+    case (mld_l1_bjac_)
+      call lv%set(mld_c_l1_jac_smoother_mold,info,pos=pos)
+      if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
 
     case (mld_as_)
       call lv%set(mld_c_as_smoother_mold,info,pos=pos)

mlprec/impl/level/mld_c_base_onelev_dump.f90

@@ -146,13 +146,24 @@ subroutine mld_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
     end if
   end if
   
-  if (allocated(lv%sm)) then
-    call lv%sm%dump(icontxt,level,info,smoother=smoother, &
-         & solver=solver,prefix=trim(prefix_)//"_sm")
-  end if
-  if (allocated(lv%sm2a)) then
-    call lv%sm2a%dump(icontxt,level,info,smoother=smoother, &
-         & solver=solver,prefix=trim(prefix_)//"_sm2a")
+  if (level >= 2) then 
+    if (allocated(lv%sm)) then
+      call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+    end if
+    if (allocated(lv%sm2a)) then
+      call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+    end if
+  else
+    if (allocated(lv%sm)) then
+      call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+    end if
+    if (allocated(lv%sm2a)) then
+      call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+    end if
   end if
   
 end subroutine mld_c_base_onelev_dump

mlprec/impl/level/mld_c_base_onelev_mat_asb.f90

@@ -83,7 +83,7 @@
 !    info    -  integer, output.
 !               Error code.         
 !  
-subroutine mld_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
+subroutine mld_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
 
   use psb_base_mod
   use mld_base_prec_type
@@ -97,19 +97,16 @@ subroutine mld_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   type(psb_desc_type), intent(inout)   :: desc_a
   integer(psb_lpk_), intent(inout) :: nlaggr(:)
   integer(psb_lpk_), intent(inout) :: ilaggr(:)
-  type(psb_lcspmat_type), intent(inout)  :: op_prol
+  type(psb_lcspmat_type), intent(inout)  :: t_prol
   integer(psb_ipk_), intent(out)      :: info
   
 
   ! Local variables
-  character(len=24)                :: name
-  integer(psb_ipk_)               :: ictxt, np, me
-  integer(psb_ipk_)                :: err_act
-  type(psb_lcspmat_type)           :: lac, op_restr
-  type(psb_cspmat_type)            :: ac, iop_restr, iop_prol
-  type(psb_lc_coo_sparse_mat)       :: acoo, bcoo
-  type(psb_lc_csr_sparse_mat)       :: acsr1
-  integer(psb_ipk_)                :: nzl, inl
+  character(len=24)            :: name
+  integer(psb_ipk_)            :: ictxt, np, me
+  integer(psb_ipk_)            :: err_act
+  type(psb_cspmat_type)        :: ac, op_restr, op_prol
+  integer(psb_ipk_)            :: nzl, inl
   integer(psb_ipk_)            :: debug_level, debug_unit
 
   name='mld_c_onelev_mat_asb'
@@ -141,7 +138,8 @@ subroutine mld_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   ! the mapping defined by mld_aggrmap_bld and applying the aggregation
   ! algorithm specified by lv%iprcparm(mld_aggr_prol_)
   !
-  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,lac,op_prol,op_restr,info)
+  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
+       & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb')
@@ -153,10 +151,9 @@ subroutine mld_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   ! ac, op_restr and op_prol
   !
   if (info == psb_success_) &
-       & call lv%aggr%mat_asb(lv%parms,a,desc_a,ilaggr,nlaggr,&
-       & lac,lv%desc_ac,op_prol,op_restr,info)
+       & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
+       & lv%ac,lv%desc_ac,op_prol,op_restr,info)
   
-  call lv%ac%mv_from_l(lac)
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
   if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&

mlprec/impl/level/mld_d_base_onelev_csetc.F90

@@ -75,15 +75,16 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos,idx)
   integer(psb_ipk_)  :: ipos_, err_act
   character(len=20) :: name='d_base_onelev_csetc'
   integer(psb_ipk_) :: ival 
-  type(mld_d_base_smoother_type)  :: mld_d_base_smoother_mold
-  type(mld_d_jac_smoother_type)   ::  mld_d_jac_smoother_mold
-  type(mld_d_as_smoother_type)    ::  mld_d_as_smoother_mold
-  type(mld_d_diag_solver_type)    ::  mld_d_diag_solver_mold
-  type(mld_d_l1_diag_solver_type) ::  mld_d_l1_diag_solver_mold
-  type(mld_d_ilu_solver_type)     ::  mld_d_ilu_solver_mold
-  type(mld_d_id_solver_type)      ::  mld_d_id_solver_mold
-  type(mld_d_gs_solver_type)      ::  mld_d_gs_solver_mold
-  type(mld_d_bwgs_solver_type)    ::  mld_d_bwgs_solver_mold
+  type(mld_d_base_smoother_type)   :: mld_d_base_smoother_mold
+  type(mld_d_jac_smoother_type)    ::  mld_d_jac_smoother_mold
+  type(mld_d_l1_jac_smoother_type) ::  mld_d_l1_jac_smoother_mold
+  type(mld_d_as_smoother_type)     ::  mld_d_as_smoother_mold
+  type(mld_d_diag_solver_type)     ::  mld_d_diag_solver_mold
+  type(mld_d_l1_diag_solver_type)  ::  mld_d_l1_diag_solver_mold
+  type(mld_d_ilu_solver_type)      ::  mld_d_ilu_solver_mold
+  type(mld_d_id_solver_type)       ::  mld_d_id_solver_mold
+  type(mld_d_gs_solver_type)       ::  mld_d_gs_solver_mold
+  type(mld_d_bwgs_solver_type)     ::  mld_d_bwgs_solver_mold
 #if defined(HAVE_UMF_)
   type(mld_d_umf_solver_type)     ::  mld_d_umf_solver_mold
 #endif
@@ -136,16 +137,41 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos,idx)
     case ('BJAC')
       call lv%set(mld_d_jac_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
+      
+    case ('L1-BJAC')
+      call lv%set(mld_d_l1_jac_smoother_mold,info,pos=pos)
+      if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
 
     case ('AS')
       call lv%set(mld_d_as_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
 
+    case ('GS','FWGS')
+      call lv%set(mld_d_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_d_gs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+    case ('BWGS')
+      call lv%set(mld_d_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_d_bwgs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
     case ('FBGS')
       call lv%set(mld_d_jac_smoother_mold,info,pos='pre')
       if (info == 0) call lv%set(mld_d_gs_solver_mold,info,pos='pre')
       call lv%set(mld_d_jac_smoother_mold,info,pos='post')
       if (info == 0) call lv%set(mld_d_bwgs_solver_mold,info,pos='post')
+    case ('L1-GS','L1-FWGS')
+      call lv%set(mld_d_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_d_gs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+    case ('L1-BWGS')
+      call lv%set(mld_d_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_d_bwgs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)      
+    case ('L1-FBGS')
+      call lv%set(mld_d_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_d_gs_solver_mold,info,pos='pre')
+      call lv%set(mld_d_l1_jac_smoother_mold,info,pos='post')
+      if (info == 0) call lv%set(mld_d_bwgs_solver_mold,info,pos='post')
       
     case default
       !

mlprec/impl/level/mld_d_base_onelev_cseti.F90

@@ -74,15 +74,16 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx)
   ! Local 
   integer(psb_ipk_)  :: ipos_, err_act
   character(len=20) :: name='d_base_onelev_cseti'
-  type(mld_d_base_smoother_type)  :: mld_d_base_smoother_mold
-  type(mld_d_jac_smoother_type)   ::  mld_d_jac_smoother_mold
-  type(mld_d_as_smoother_type)    ::  mld_d_as_smoother_mold
-  type(mld_d_diag_solver_type)    ::  mld_d_diag_solver_mold
-  type(mld_d_l1_diag_solver_type) ::  mld_d_l1_diag_solver_mold
-  type(mld_d_ilu_solver_type)     ::  mld_d_ilu_solver_mold
-  type(mld_d_id_solver_type)      ::  mld_d_id_solver_mold
-  type(mld_d_gs_solver_type)      ::  mld_d_gs_solver_mold
-  type(mld_d_bwgs_solver_type)    ::  mld_d_bwgs_solver_mold
+  type(mld_d_base_smoother_type)   :: mld_d_base_smoother_mold
+  type(mld_d_jac_smoother_type)    ::  mld_d_jac_smoother_mold
+  type(mld_d_l1_jac_smoother_type) ::  mld_d_l1_jac_smoother_mold
+  type(mld_d_as_smoother_type)     ::  mld_d_as_smoother_mold
+  type(mld_d_diag_solver_type)     ::  mld_d_diag_solver_mold
+  type(mld_d_l1_diag_solver_type)  ::  mld_d_l1_diag_solver_mold
+  type(mld_d_ilu_solver_type)      ::  mld_d_ilu_solver_mold
+  type(mld_d_id_solver_type)       ::  mld_d_id_solver_mold
+  type(mld_d_gs_solver_type)       ::  mld_d_gs_solver_mold
+  type(mld_d_bwgs_solver_type)     ::  mld_d_bwgs_solver_mold
 #if defined(HAVE_UMF_)
   type(mld_d_umf_solver_type)     ::  mld_d_umf_solver_mold
 #endif
@@ -130,6 +131,10 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx)
     case (mld_bjac_)
       call lv%set(mld_d_jac_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
+      
+    case (mld_l1_bjac_)
+      call lv%set(mld_d_l1_jac_smoother_mold,info,pos=pos)
+      if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
 
     case (mld_as_)
       call lv%set(mld_d_as_smoother_mold,info,pos=pos)

mlprec/impl/level/mld_d_base_onelev_dump.f90

@@ -146,13 +146,24 @@ subroutine mld_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
     end if
   end if
   
-  if (allocated(lv%sm)) then
-    call lv%sm%dump(icontxt,level,info,smoother=smoother, &
-         & solver=solver,prefix=trim(prefix_)//"_sm")
-  end if
-  if (allocated(lv%sm2a)) then
-    call lv%sm2a%dump(icontxt,level,info,smoother=smoother, &
-         & solver=solver,prefix=trim(prefix_)//"_sm2a")
+  if (level >= 2) then 
+    if (allocated(lv%sm)) then
+      call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+    end if
+    if (allocated(lv%sm2a)) then
+      call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+    end if
+  else
+    if (allocated(lv%sm)) then
+      call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+    end if
+    if (allocated(lv%sm2a)) then
+      call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+    end if
   end if
   
 end subroutine mld_d_base_onelev_dump

mlprec/impl/level/mld_d_base_onelev_mat_asb.f90

@@ -83,7 +83,7 @@
 !    info    -  integer, output.
 !               Error code.         
 !  
-subroutine mld_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
+subroutine mld_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
 
   use psb_base_mod
   use mld_base_prec_type
@@ -97,19 +97,16 @@ subroutine mld_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   type(psb_desc_type), intent(inout)   :: desc_a
   integer(psb_lpk_), intent(inout) :: nlaggr(:)
   integer(psb_lpk_), intent(inout) :: ilaggr(:)
-  type(psb_ldspmat_type), intent(inout)  :: op_prol
+  type(psb_ldspmat_type), intent(inout)  :: t_prol
   integer(psb_ipk_), intent(out)      :: info
   
 
   ! Local variables
-  character(len=24)                :: name
-  integer(psb_ipk_)               :: ictxt, np, me
-  integer(psb_ipk_)                :: err_act
-  type(psb_ldspmat_type)           :: lac, op_restr
-  type(psb_dspmat_type)            :: ac, iop_restr, iop_prol
-  type(psb_ld_coo_sparse_mat)       :: acoo, bcoo
-  type(psb_ld_csr_sparse_mat)       :: acsr1
-  integer(psb_ipk_)                :: nzl, inl
+  character(len=24)            :: name
+  integer(psb_ipk_)            :: ictxt, np, me
+  integer(psb_ipk_)            :: err_act
+  type(psb_dspmat_type)        :: ac, op_restr, op_prol
+  integer(psb_ipk_)            :: nzl, inl
   integer(psb_ipk_)            :: debug_level, debug_unit
 
   name='mld_d_onelev_mat_asb'
@@ -141,7 +138,8 @@ subroutine mld_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   ! the mapping defined by mld_aggrmap_bld and applying the aggregation
   ! algorithm specified by lv%iprcparm(mld_aggr_prol_)
   !
-  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,lac,op_prol,op_restr,info)
+  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
+       & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb')
@@ -153,10 +151,9 @@ subroutine mld_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   ! ac, op_restr and op_prol
   !
   if (info == psb_success_) &
-       & call lv%aggr%mat_asb(lv%parms,a,desc_a,ilaggr,nlaggr,&
-       & lac,lv%desc_ac,op_prol,op_restr,info)
+       & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
+       & lv%ac,lv%desc_ac,op_prol,op_restr,info)
   
-  call lv%ac%mv_from_l(lac)
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
   if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&

mlprec/impl/level/mld_s_base_onelev_csetc.F90

@@ -69,15 +69,16 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos,idx)
   integer(psb_ipk_)  :: ipos_, err_act
   character(len=20) :: name='s_base_onelev_csetc'
   integer(psb_ipk_) :: ival 
-  type(mld_s_base_smoother_type)  :: mld_s_base_smoother_mold
-  type(mld_s_jac_smoother_type)   ::  mld_s_jac_smoother_mold
-  type(mld_s_as_smoother_type)    ::  mld_s_as_smoother_mold
-  type(mld_s_diag_solver_type)    ::  mld_s_diag_solver_mold
-  type(mld_s_l1_diag_solver_type) ::  mld_s_l1_diag_solver_mold
-  type(mld_s_ilu_solver_type)     ::  mld_s_ilu_solver_mold
-  type(mld_s_id_solver_type)      ::  mld_s_id_solver_mold
-  type(mld_s_gs_solver_type)      ::  mld_s_gs_solver_mold
-  type(mld_s_bwgs_solver_type)    ::  mld_s_bwgs_solver_mold
+  type(mld_s_base_smoother_type)   :: mld_s_base_smoother_mold
+  type(mld_s_jac_smoother_type)    ::  mld_s_jac_smoother_mold
+  type(mld_s_l1_jac_smoother_type) ::  mld_s_l1_jac_smoother_mold
+  type(mld_s_as_smoother_type)     ::  mld_s_as_smoother_mold
+  type(mld_s_diag_solver_type)     ::  mld_s_diag_solver_mold
+  type(mld_s_l1_diag_solver_type)  ::  mld_s_l1_diag_solver_mold
+  type(mld_s_ilu_solver_type)      ::  mld_s_ilu_solver_mold
+  type(mld_s_id_solver_type)       ::  mld_s_id_solver_mold
+  type(mld_s_gs_solver_type)       ::  mld_s_gs_solver_mold
+  type(mld_s_bwgs_solver_type)     ::  mld_s_bwgs_solver_mold
 #if defined(HAVE_SLU_)
   type(mld_s_slu_solver_type)   ::  mld_s_slu_solver_mold
 #endif
@@ -124,16 +125,41 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos,idx)
     case ('BJAC')
       call lv%set(mld_s_jac_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
+      
+    case ('L1-BJAC')
+      call lv%set(mld_s_l1_jac_smoother_mold,info,pos=pos)
+      if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
 
     case ('AS')
       call lv%set(mld_s_as_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
 
+    case ('GS','FWGS')
+      call lv%set(mld_s_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_s_gs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+    case ('BWGS')
+      call lv%set(mld_s_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_s_bwgs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
     case ('FBGS')
       call lv%set(mld_s_jac_smoother_mold,info,pos='pre')
       if (info == 0) call lv%set(mld_s_gs_solver_mold,info,pos='pre')
       call lv%set(mld_s_jac_smoother_mold,info,pos='post')
       if (info == 0) call lv%set(mld_s_bwgs_solver_mold,info,pos='post')
+    case ('L1-GS','L1-FWGS')
+      call lv%set(mld_s_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_s_gs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+    case ('L1-BWGS')
+      call lv%set(mld_s_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_s_bwgs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)      
+    case ('L1-FBGS')
+      call lv%set(mld_s_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_s_gs_solver_mold,info,pos='pre')
+      call lv%set(mld_s_l1_jac_smoother_mold,info,pos='post')
+      if (info == 0) call lv%set(mld_s_bwgs_solver_mold,info,pos='post')
       
     case default
       !

mlprec/impl/level/mld_s_base_onelev_cseti.F90

@@ -68,15 +68,16 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx)
   ! Local 
   integer(psb_ipk_)  :: ipos_, err_act
   character(len=20) :: name='s_base_onelev_cseti'
-  type(mld_s_base_smoother_type)  :: mld_s_base_smoother_mold
-  type(mld_s_jac_smoother_type)   ::  mld_s_jac_smoother_mold
-  type(mld_s_as_smoother_type)    ::  mld_s_as_smoother_mold
-  type(mld_s_diag_solver_type)    ::  mld_s_diag_solver_mold
-  type(mld_s_l1_diag_solver_type) ::  mld_s_l1_diag_solver_mold
-  type(mld_s_ilu_solver_type)     ::  mld_s_ilu_solver_mold
-  type(mld_s_id_solver_type)      ::  mld_s_id_solver_mold
-  type(mld_s_gs_solver_type)      ::  mld_s_gs_solver_mold
-  type(mld_s_bwgs_solver_type)    ::  mld_s_bwgs_solver_mold
+  type(mld_s_base_smoother_type)   :: mld_s_base_smoother_mold
+  type(mld_s_jac_smoother_type)    ::  mld_s_jac_smoother_mold
+  type(mld_s_l1_jac_smoother_type) ::  mld_s_l1_jac_smoother_mold
+  type(mld_s_as_smoother_type)     ::  mld_s_as_smoother_mold
+  type(mld_s_diag_solver_type)     ::  mld_s_diag_solver_mold
+  type(mld_s_l1_diag_solver_type)  ::  mld_s_l1_diag_solver_mold
+  type(mld_s_ilu_solver_type)      ::  mld_s_ilu_solver_mold
+  type(mld_s_id_solver_type)       ::  mld_s_id_solver_mold
+  type(mld_s_gs_solver_type)       ::  mld_s_gs_solver_mold
+  type(mld_s_bwgs_solver_type)     ::  mld_s_bwgs_solver_mold
 #if defined(HAVE_SLU_)
   type(mld_s_slu_solver_type)   ::  mld_s_slu_solver_mold
 #endif
@@ -118,6 +119,10 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx)
     case (mld_bjac_)
       call lv%set(mld_s_jac_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
+      
+    case (mld_l1_bjac_)
+      call lv%set(mld_s_l1_jac_smoother_mold,info,pos=pos)
+      if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
 
     case (mld_as_)
       call lv%set(mld_s_as_smoother_mold,info,pos=pos)

mlprec/impl/level/mld_s_base_onelev_dump.f90

@@ -146,13 +146,24 @@ subroutine mld_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
     end if
   end if
   
-  if (allocated(lv%sm)) then
-    call lv%sm%dump(icontxt,level,info,smoother=smoother, &
-         & solver=solver,prefix=trim(prefix_)//"_sm")
-  end if
-  if (allocated(lv%sm2a)) then
-    call lv%sm2a%dump(icontxt,level,info,smoother=smoother, &
-         & solver=solver,prefix=trim(prefix_)//"_sm2a")
+  if (level >= 2) then 
+    if (allocated(lv%sm)) then
+      call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+    end if
+    if (allocated(lv%sm2a)) then
+      call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+    end if
+  else
+    if (allocated(lv%sm)) then
+      call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+    end if
+    if (allocated(lv%sm2a)) then
+      call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+    end if
   end if
   
 end subroutine mld_s_base_onelev_dump

mlprec/impl/level/mld_s_base_onelev_mat_asb.f90

@@ -83,7 +83,7 @@
 !    info    -  integer, output.
 !               Error code.         
 !  
-subroutine mld_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
+subroutine mld_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
 
   use psb_base_mod
   use mld_base_prec_type
@@ -97,19 +97,16 @@ subroutine mld_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   type(psb_desc_type), intent(inout)   :: desc_a
   integer(psb_lpk_), intent(inout) :: nlaggr(:)
   integer(psb_lpk_), intent(inout) :: ilaggr(:)
-  type(psb_lsspmat_type), intent(inout)  :: op_prol
+  type(psb_lsspmat_type), intent(inout)  :: t_prol
   integer(psb_ipk_), intent(out)      :: info
   
 
   ! Local variables
-  character(len=24)                :: name
-  integer(psb_ipk_)               :: ictxt, np, me
-  integer(psb_ipk_)                :: err_act
-  type(psb_lsspmat_type)           :: lac, op_restr
-  type(psb_sspmat_type)            :: ac, iop_restr, iop_prol
-  type(psb_ls_coo_sparse_mat)       :: acoo, bcoo
-  type(psb_ls_csr_sparse_mat)       :: acsr1
-  integer(psb_ipk_)                :: nzl, inl
+  character(len=24)            :: name
+  integer(psb_ipk_)            :: ictxt, np, me
+  integer(psb_ipk_)            :: err_act
+  type(psb_sspmat_type)        :: ac, op_restr, op_prol
+  integer(psb_ipk_)            :: nzl, inl
   integer(psb_ipk_)            :: debug_level, debug_unit
 
   name='mld_s_onelev_mat_asb'
@@ -141,7 +138,8 @@ subroutine mld_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   ! the mapping defined by mld_aggrmap_bld and applying the aggregation
   ! algorithm specified by lv%iprcparm(mld_aggr_prol_)
   !
-  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,lac,op_prol,op_restr,info)
+  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
+       & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb')
@@ -153,10 +151,9 @@ subroutine mld_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   ! ac, op_restr and op_prol
   !
   if (info == psb_success_) &
-       & call lv%aggr%mat_asb(lv%parms,a,desc_a,ilaggr,nlaggr,&
-       & lac,lv%desc_ac,op_prol,op_restr,info)
+       & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
+       & lv%ac,lv%desc_ac,op_prol,op_restr,info)
   
-  call lv%ac%mv_from_l(lac)
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
   if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&

mlprec/impl/level/mld_z_base_onelev_csetc.F90

@@ -75,15 +75,16 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos,idx)
   integer(psb_ipk_)  :: ipos_, err_act
   character(len=20) :: name='z_base_onelev_csetc'
   integer(psb_ipk_) :: ival 
-  type(mld_z_base_smoother_type)  :: mld_z_base_smoother_mold
-  type(mld_z_jac_smoother_type)   ::  mld_z_jac_smoother_mold
-  type(mld_z_as_smoother_type)    ::  mld_z_as_smoother_mold
-  type(mld_z_diag_solver_type)    ::  mld_z_diag_solver_mold
-  type(mld_z_l1_diag_solver_type) ::  mld_z_l1_diag_solver_mold
-  type(mld_z_ilu_solver_type)     ::  mld_z_ilu_solver_mold
-  type(mld_z_id_solver_type)      ::  mld_z_id_solver_mold
-  type(mld_z_gs_solver_type)      ::  mld_z_gs_solver_mold
-  type(mld_z_bwgs_solver_type)    ::  mld_z_bwgs_solver_mold
+  type(mld_z_base_smoother_type)   :: mld_z_base_smoother_mold
+  type(mld_z_jac_smoother_type)    ::  mld_z_jac_smoother_mold
+  type(mld_z_l1_jac_smoother_type) ::  mld_z_l1_jac_smoother_mold
+  type(mld_z_as_smoother_type)     ::  mld_z_as_smoother_mold
+  type(mld_z_diag_solver_type)     ::  mld_z_diag_solver_mold
+  type(mld_z_l1_diag_solver_type)  ::  mld_z_l1_diag_solver_mold
+  type(mld_z_ilu_solver_type)      ::  mld_z_ilu_solver_mold
+  type(mld_z_id_solver_type)       ::  mld_z_id_solver_mold
+  type(mld_z_gs_solver_type)       ::  mld_z_gs_solver_mold
+  type(mld_z_bwgs_solver_type)     ::  mld_z_bwgs_solver_mold
 #if defined(HAVE_UMF_)
   type(mld_z_umf_solver_type)     ::  mld_z_umf_solver_mold
 #endif
@@ -136,16 +137,41 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos,idx)
     case ('BJAC')
       call lv%set(mld_z_jac_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
+      
+    case ('L1-BJAC')
+      call lv%set(mld_z_l1_jac_smoother_mold,info,pos=pos)
+      if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
 
     case ('AS')
       call lv%set(mld_z_as_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
 
+    case ('GS','FWGS')
+      call lv%set(mld_z_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_z_gs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+    case ('BWGS')
+      call lv%set(mld_z_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_z_bwgs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
     case ('FBGS')
       call lv%set(mld_z_jac_smoother_mold,info,pos='pre')
       if (info == 0) call lv%set(mld_z_gs_solver_mold,info,pos='pre')
       call lv%set(mld_z_jac_smoother_mold,info,pos='post')
       if (info == 0) call lv%set(mld_z_bwgs_solver_mold,info,pos='post')
+    case ('L1-GS','L1-FWGS')
+      call lv%set(mld_z_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_z_gs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)
+    case ('L1-BWGS')
+      call lv%set(mld_z_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_z_bwgs_solver_mold,info,pos='pre')
+      if (allocated(lv%sm2a)) deallocate(lv%sm2a)      
+    case ('L1-FBGS')
+      call lv%set(mld_z_l1_jac_smoother_mold,info,pos='pre')
+      if (info == 0) call lv%set(mld_z_gs_solver_mold,info,pos='pre')
+      call lv%set(mld_z_l1_jac_smoother_mold,info,pos='post')
+      if (info == 0) call lv%set(mld_z_bwgs_solver_mold,info,pos='post')
       
     case default
       !

mlprec/impl/level/mld_z_base_onelev_cseti.F90

@@ -74,15 +74,16 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx)
   ! Local 
   integer(psb_ipk_)  :: ipos_, err_act
   character(len=20) :: name='z_base_onelev_cseti'
-  type(mld_z_base_smoother_type)  :: mld_z_base_smoother_mold
-  type(mld_z_jac_smoother_type)   ::  mld_z_jac_smoother_mold
-  type(mld_z_as_smoother_type)    ::  mld_z_as_smoother_mold
-  type(mld_z_diag_solver_type)    ::  mld_z_diag_solver_mold
-  type(mld_z_l1_diag_solver_type) ::  mld_z_l1_diag_solver_mold
-  type(mld_z_ilu_solver_type)     ::  mld_z_ilu_solver_mold
-  type(mld_z_id_solver_type)      ::  mld_z_id_solver_mold
-  type(mld_z_gs_solver_type)      ::  mld_z_gs_solver_mold
-  type(mld_z_bwgs_solver_type)    ::  mld_z_bwgs_solver_mold
+  type(mld_z_base_smoother_type)   :: mld_z_base_smoother_mold
+  type(mld_z_jac_smoother_type)    ::  mld_z_jac_smoother_mold
+  type(mld_z_l1_jac_smoother_type) ::  mld_z_l1_jac_smoother_mold
+  type(mld_z_as_smoother_type)     ::  mld_z_as_smoother_mold
+  type(mld_z_diag_solver_type)     ::  mld_z_diag_solver_mold
+  type(mld_z_l1_diag_solver_type)  ::  mld_z_l1_diag_solver_mold
+  type(mld_z_ilu_solver_type)      ::  mld_z_ilu_solver_mold
+  type(mld_z_id_solver_type)       ::  mld_z_id_solver_mold
+  type(mld_z_gs_solver_type)       ::  mld_z_gs_solver_mold
+  type(mld_z_bwgs_solver_type)     ::  mld_z_bwgs_solver_mold
 #if defined(HAVE_UMF_)
   type(mld_z_umf_solver_type)     ::  mld_z_umf_solver_mold
 #endif
@@ -130,6 +131,10 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx)
     case (mld_bjac_)
       call lv%set(mld_z_jac_smoother_mold,info,pos=pos)
       if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
+      
+    case (mld_l1_bjac_)
+      call lv%set(mld_z_l1_jac_smoother_mold,info,pos=pos)
+      if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
 
     case (mld_as_)
       call lv%set(mld_z_as_smoother_mold,info,pos=pos)

mlprec/impl/level/mld_z_base_onelev_dump.f90

@@ -146,13 +146,24 @@ subroutine mld_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
     end if
   end if
   
-  if (allocated(lv%sm)) then
-    call lv%sm%dump(icontxt,level,info,smoother=smoother, &
-         & solver=solver,prefix=trim(prefix_)//"_sm")
-  end if
-  if (allocated(lv%sm2a)) then
-    call lv%sm2a%dump(icontxt,level,info,smoother=smoother, &
-         & solver=solver,prefix=trim(prefix_)//"_sm2a")
+  if (level >= 2) then 
+    if (allocated(lv%sm)) then
+      call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+    end if
+    if (allocated(lv%sm2a)) then
+      call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+    end if
+  else
+    if (allocated(lv%sm)) then
+      call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
+    end if
+    if (allocated(lv%sm2a)) then
+      call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
+           & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
+    end if
   end if
   
 end subroutine mld_z_base_onelev_dump

mlprec/impl/level/mld_z_base_onelev_mat_asb.f90

@@ -83,7 +83,7 @@
 !    info    -  integer, output.
 !               Error code.         
 !  
-subroutine mld_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
+subroutine mld_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
 
   use psb_base_mod
   use mld_base_prec_type
@@ -97,19 +97,16 @@ subroutine mld_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   type(psb_desc_type), intent(inout)   :: desc_a
   integer(psb_lpk_), intent(inout) :: nlaggr(:)
   integer(psb_lpk_), intent(inout) :: ilaggr(:)
-  type(psb_lzspmat_type), intent(inout)  :: op_prol
+  type(psb_lzspmat_type), intent(inout)  :: t_prol
   integer(psb_ipk_), intent(out)      :: info
   
 
   ! Local variables
-  character(len=24)                :: name
-  integer(psb_ipk_)               :: ictxt, np, me
-  integer(psb_ipk_)                :: err_act
-  type(psb_lzspmat_type)           :: lac, op_restr
-  type(psb_zspmat_type)            :: ac, iop_restr, iop_prol
-  type(psb_lz_coo_sparse_mat)       :: acoo, bcoo
-  type(psb_lz_csr_sparse_mat)       :: acsr1
-  integer(psb_ipk_)                :: nzl, inl
+  character(len=24)            :: name
+  integer(psb_ipk_)            :: ictxt, np, me
+  integer(psb_ipk_)            :: err_act
+  type(psb_zspmat_type)        :: ac, op_restr, op_prol
+  integer(psb_ipk_)            :: nzl, inl
   integer(psb_ipk_)            :: debug_level, debug_unit
 
   name='mld_z_onelev_mat_asb'
@@ -141,7 +138,8 @@ subroutine mld_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   ! the mapping defined by mld_aggrmap_bld and applying the aggregation
   ! algorithm specified by lv%iprcparm(mld_aggr_prol_)
   !
-  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,lac,op_prol,op_restr,info)
+  call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
+       & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
 
   if(info /= psb_success_) then
     call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb')
@@ -153,10 +151,9 @@ subroutine mld_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,op_prol,info)
   ! ac, op_restr and op_prol
   !
   if (info == psb_success_) &
-       & call lv%aggr%mat_asb(lv%parms,a,desc_a,ilaggr,nlaggr,&
-       & lac,lv%desc_ac,op_prol,op_restr,info)
+       & call lv%aggr%mat_asb(lv%parms,a,desc_a,&
+       & lv%ac,lv%desc_ac,op_prol,op_restr,info)
   
-  call lv%ac%mv_from_l(lac)
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
   if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&

mlprec/impl/mld_c_hierarchy_bld.f90

@@ -273,10 +273,12 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
   end if
 
   !
-  ! Finest level first; remember to fix base_a and base_desc
+  ! Finest level first; create a GEN_BLOCK
+  ! copy of the descriptor. 
   ! 
   prec%precv(1)%base_a    => a
-  prec%precv(1)%base_desc => desc_a
+  call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
+  prec%precv(1)%base_desc => prec%precv(1)%desc_ac
   newsz = 0
   array_build_loop: do i=2, iszv
     !
@@ -317,7 +319,7 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
 
     if (debug_level >= psb_debug_outer_) &
          & write(debug_unit,*) me,' ',trim(name),&
-         & 'Return from ',i,' call to mlprcbld ',info      
+         & 'Return from ',i,' call to bld_tprol', info      
     !
     ! Save op_prol just in case
     !
@@ -334,9 +336,9 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
       sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
     end if
     prec%precv(i)%szratio = sizeratio
-    if (iaggsize <= casize) then
-      newsz = i      
-    end if
+
+    if (iaggsize <= casize) newsz = i      
+    if (i == iszv)          newsz = i
 
     if (i>2) then
       if (sizeratio < mnaggratio) then
@@ -440,7 +442,10 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
     ! Restart
     iszv = newsz
     ! Fix the pointers, but the level 1 should
-    ! be already OK
+    ! be treated differently
+    if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
+      prec%precv(1)%base_desc => prec%precv(1)%desc_ac
+    end if
     do i=2, iszv 
       prec%precv(i)%base_a       => prec%precv(i)%ac
       prec%precv(i)%base_desc    => prec%precv(i)%desc_ac
@@ -449,11 +454,6 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
     end do
   end if
 
-  ! Does the coarsening need backfix on descriptors? 
-  do i=2, iszv 
-    if (info == psb_success_) call prec%precv(i)%backfix(prec%precv(i-1),info)    
-  end do
-  
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
          & a_err='Internal hierarchy build' )
@@ -478,7 +478,7 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
 
 contains
   subroutine save_smoothers(level,save1, save2,info)
-    type(mld_c_onelev_type), intent(in) :: level
+    type(mld_c_onelev_type), intent(inout) :: level
     class(mld_c_base_smoother_type), allocatable , intent(inout) :: save1, save2
     integer(psb_ipk_), intent(out) :: info
 
@@ -493,15 +493,19 @@ contains
       if (info  == 0) deallocate(save2,stat=info)
       if (info /= 0) return
     end if
-    allocate(save1, source=level%sm,stat=info) 
-    if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info) 
-
+    allocate(save1, mold=level%sm,stat=info)
+    if (info == 0) call level%sm%clone_settings(save1,info)
+    if ((info == 0).and.allocated(level%sm2a)) then
+      allocate(save2, mold=level%sm2a,stat=info) 
+      if (info == 0) call level%sm2a%clone_settings(save2,info)
+    end if
+    
     return
   end subroutine save_smoothers
 
   subroutine restore_smoothers(level,save1, save2,info)
     type(mld_c_onelev_type), intent(inout), target :: level
-    class(mld_c_base_smoother_type), allocatable, intent(in) :: save1, save2
+    class(mld_c_base_smoother_type), allocatable, intent(inout) :: save1, save2
     integer(psb_ipk_), intent(out) :: info
 
     info  = 0
@@ -511,7 +515,8 @@ contains
       if (info  == 0) deallocate(level%sm,stat=info)
     end if
     if (allocated(save1)) then
-      if (info  == 0) allocate(level%sm,source=save1,stat=info)
+      if (info  == 0) allocate(level%sm,mold=save1,stat=info)
+      if (info == 0) call save1%clone_settings(level%sm,info)
     end if
     
     if (info /= 0) return
@@ -521,7 +526,8 @@ contains
       if (info  == 0) deallocate(level%sm2a,stat=info)
     end if
     if (allocated(save2)) then
-      if (info  == 0) allocate(level%sm2a,source=save2,stat=info)
+      if (info  == 0) allocate(level%sm2a,mold=save2,stat=info)
+      if (info == 0) call save2%clone_settings(level%sm2a,info)
       if (info  == 0) level%sm2 => level%sm2a
     else
       if (allocated(level%sm)) level%sm2 => level%sm

mlprec/impl/mld_c_smoothers_bld.f90

@@ -256,7 +256,7 @@ subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
              & ' but the coarse matrix has been changed to replicated'
       end if
         
-    case(mld_bjac_,mld_jac_, mld_l1_jac_)
+    case(mld_bjac_,mld_l1_bjac_,mld_jac_, mld_l1_jac_, mld_gs_, mld_fbgs_, mld_l1_gs_,mld_l1_fbgs_)
       if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
         write(psb_err_unit,*) &
              & 'MLD2P4: Warning: original coarse solver was requested as ',&

mlprec/impl/mld_ccprecset.F90

@@ -188,75 +188,75 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
           info = -2
           return
         end if
-      if (nlev_ > 1) then 
-        call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
-        select case (val) 
-        case(mld_bjac_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+        if (nlev_ > 1) then 
+          call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
+          select case (val) 
+          case(mld_bjac_,mld_l1_bjac_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
 #endif
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
-        case(mld_slu_)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
+          case(mld_slu_)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
-        case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
-        case(mld_mumps_)
+          case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+          case(mld_mumps_)
 #if defined(HAVE_MUMPS_)          
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
-       case(mld_umf_)
+         case(mld_umf_)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
           
-        case(mld_sludist_)
+          case(mld_sludist_)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
           case(mld_jac_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
@@ -267,6 +267,18 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
             call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_gs_,mld_fbgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_bwgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_l1_gs_,mld_l1_fbgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
           end select
           
         endif
@@ -325,8 +337,8 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
       if (nlev_ > 1) then 
         call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
         select case (val) 
-        case(mld_bjac_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+        case(mld_bjac_,mld_l1_bjac_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
 #if defined(HAVE_SLU_)
           call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
@@ -401,6 +413,18 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_gs_,mld_fbgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_bwgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_l1_gs_,mld_l1_fbgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
         end select
       endif
 
@@ -569,75 +593,75 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
           info = -2
           return
         end if
-      if (nlev_ > 1) then 
-        call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
-        select case (psb_toupper(trim(string))) 
-        case('BJAC')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+        if (nlev_ > 1) then 
+          call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
+          select case (psb_toupper(trim(string))) 
+          case('BJAC', 'L1-BJAC')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
 #endif
-          call p%precv(nlev_)%set('COARSE_MAT','dist',info)
-        case('SLU')
+            call p%precv(nlev_)%set('COARSE_MAT','dist',info)
+          case('SLU')
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
-        case('ILU','MILU','ILUT')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
-        case('MUMPS')
+          case('ILU','MILU','ILUT')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+          case('MUMPS')
 #if defined(HAVE_MUMPS_)          
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC'_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
-       case('UMF')
+         case('UMF')
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
           
-        case('SLUDIST')
+          case('SLUDIST')
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
           case('JAC','JACOBI')
             call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
@@ -648,6 +672,18 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
             call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
             call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('GS','FWGS','FBGS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('BWGS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('L1-GS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)          
           end select
           
         endif
@@ -687,9 +723,9 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
     case('COARSE_SOLVE')
       if (nlev_ > 1) then 
         call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
-        select case (string) 
-        case('BJAC')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+        select case (psb_toupper(trim(string)))
+        case('BJAC', 'L1-BJAC')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
 #if defined(HAVE_SLU_)
           call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
@@ -759,11 +795,22 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
           call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE','DIAG',info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
-
         case('L1-JACOBI')
           call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('GS','FWGS','FBGS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('BWGS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('L1-GS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)          
         end select
       endif
 

mlprec/impl/mld_cprecinit.F90

@@ -50,10 +50,15 @@
 !
 !    'DIAG', 'JACOBI' - diagonal/Jacobi           
 !
+!    'L1-DIAG', 'L1-JACOBI' - diagonal/Jacobi  with L1 norm correction
+!
 !    'GS', 'FBGS'     - Hybrid Gauss-Seidel, also symmetrized
 !                       
 !    'BJAC'           - block Jacobi preconditioner, with ILU(0)
 !                       on the local blocks
+!                       
+!    'L1-BJAC'        - block Jacobi preconditioner, with ILU(0)
+!                       on the local blocks and L1 correction for off-diag blocks
 !
 !    'AS'             - Additive Schwarz (AS), with
 !                       overlap 1 and ILU(0) on the local submatrices
@@ -121,7 +126,7 @@ subroutine mld_cprecinit(ictxt,prec,ptype,info)
   prec%ictxt = ictxt
   prec%ag_data%min_coarse_size = -1
 
-  select case(psb_toupper(ptype(1:len_trim(ptype))))
+  select case(psb_toupper(trim(ptype)))
   case ('NOPREC','NONE') 
     nlev_ = 1
     ilev_ = 1
@@ -140,6 +145,15 @@ subroutine mld_cprecinit(ictxt,prec,ptype,info)
     allocate(mld_c_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
     call prec%precv(ilev_)%default()
 
+  case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI') 
+    nlev_ = 1
+    ilev_ = 1
+    allocate(prec%precv(nlev_),stat=info) 
+    allocate(mld_c_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info) 
+    if (info /= psb_success_) return
+    allocate(mld_c_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
+    call prec%precv(ilev_)%default()
+
   case ('GS','FWGS') 
     nlev_ = 1
     ilev_ = 1
@@ -174,6 +188,15 @@ subroutine mld_cprecinit(ictxt,prec,ptype,info)
     allocate(mld_c_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
     call prec%precv(ilev_)%default()
 
+  case ('L1-BJAC','L1_BJAC') 
+    nlev_ = 1
+    ilev_ = 1
+    allocate(prec%precv(nlev_),stat=info) 
+    allocate(mld_c_l1_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info) 
+    if (info /= psb_success_) return
+    allocate(mld_c_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
+    call prec%precv(ilev_)%default()
+
   case ('AS')
     nlev_ = 1
     ilev_ = 1
@@ -202,8 +225,7 @@ subroutine mld_cprecinit(ictxt,prec,ptype,info)
 #else
     call prec%set('COARSE_SOLVE','ILU',info)
 #endif
-    !call prec%precv(nlev_)%default()
-
+    
   case default
     write(psb_err_unit,*) name,&
          &': Warning: Unknown preconditioner type request "',ptype,'"'

mlprec/impl/mld_d_hierarchy_bld.f90

@@ -273,10 +273,12 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
   end if
 
   !
-  ! Finest level first; remember to fix base_a and base_desc
+  ! Finest level first; create a GEN_BLOCK
+  ! copy of the descriptor. 
   ! 
   prec%precv(1)%base_a    => a
-  prec%precv(1)%base_desc => desc_a
+  call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
+  prec%precv(1)%base_desc => prec%precv(1)%desc_ac
   newsz = 0
   array_build_loop: do i=2, iszv
     !
@@ -317,7 +319,7 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
 
     if (debug_level >= psb_debug_outer_) &
          & write(debug_unit,*) me,' ',trim(name),&
-         & 'Return from ',i,' call to mlprcbld ',info      
+         & 'Return from ',i,' call to bld_tprol', info      
     !
     ! Save op_prol just in case
     !
@@ -334,9 +336,9 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
       sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
     end if
     prec%precv(i)%szratio = sizeratio
-    if (iaggsize <= casize) then
-      newsz = i      
-    end if
+
+    if (iaggsize <= casize) newsz = i      
+    if (i == iszv)          newsz = i
 
     if (i>2) then
       if (sizeratio < mnaggratio) then
@@ -440,7 +442,10 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
     ! Restart
     iszv = newsz
     ! Fix the pointers, but the level 1 should
-    ! be already OK
+    ! be treated differently
+    if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
+      prec%precv(1)%base_desc => prec%precv(1)%desc_ac
+    end if
     do i=2, iszv 
       prec%precv(i)%base_a       => prec%precv(i)%ac
       prec%precv(i)%base_desc    => prec%precv(i)%desc_ac
@@ -449,11 +454,6 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
     end do
   end if
 
-  ! Does the coarsening need backfix on descriptors? 
-  do i=2, iszv 
-    if (info == psb_success_) call prec%precv(i)%backfix(prec%precv(i-1),info)    
-  end do
-  
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
          & a_err='Internal hierarchy build' )
@@ -478,7 +478,7 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
 
 contains
   subroutine save_smoothers(level,save1, save2,info)
-    type(mld_d_onelev_type), intent(in) :: level
+    type(mld_d_onelev_type), intent(inout) :: level
     class(mld_d_base_smoother_type), allocatable , intent(inout) :: save1, save2
     integer(psb_ipk_), intent(out) :: info
 
@@ -493,15 +493,19 @@ contains
       if (info  == 0) deallocate(save2,stat=info)
       if (info /= 0) return
     end if
-    allocate(save1, source=level%sm,stat=info) 
-    if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info) 
-
+    allocate(save1, mold=level%sm,stat=info)
+    if (info == 0) call level%sm%clone_settings(save1,info)
+    if ((info == 0).and.allocated(level%sm2a)) then
+      allocate(save2, mold=level%sm2a,stat=info) 
+      if (info == 0) call level%sm2a%clone_settings(save2,info)
+    end if
+    
     return
   end subroutine save_smoothers
 
   subroutine restore_smoothers(level,save1, save2,info)
     type(mld_d_onelev_type), intent(inout), target :: level
-    class(mld_d_base_smoother_type), allocatable, intent(in) :: save1, save2
+    class(mld_d_base_smoother_type), allocatable, intent(inout) :: save1, save2
     integer(psb_ipk_), intent(out) :: info
 
     info  = 0
@@ -511,7 +515,8 @@ contains
       if (info  == 0) deallocate(level%sm,stat=info)
     end if
     if (allocated(save1)) then
-      if (info  == 0) allocate(level%sm,source=save1,stat=info)
+      if (info  == 0) allocate(level%sm,mold=save1,stat=info)
+      if (info == 0) call save1%clone_settings(level%sm,info)
     end if
     
     if (info /= 0) return
@@ -521,7 +526,8 @@ contains
       if (info  == 0) deallocate(level%sm2a,stat=info)
     end if
     if (allocated(save2)) then
-      if (info  == 0) allocate(level%sm2a,source=save2,stat=info)
+      if (info  == 0) allocate(level%sm2a,mold=save2,stat=info)
+      if (info == 0) call save2%clone_settings(level%sm2a,info)
       if (info  == 0) level%sm2 => level%sm2a
     else
       if (allocated(level%sm)) level%sm2 => level%sm

mlprec/impl/mld_d_smoothers_bld.f90

@@ -256,7 +256,7 @@ subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
              & ' but the coarse matrix has been changed to replicated'
       end if
         
-    case(mld_bjac_,mld_jac_, mld_l1_jac_)
+    case(mld_bjac_,mld_l1_bjac_,mld_jac_, mld_l1_jac_, mld_gs_, mld_fbgs_, mld_l1_gs_,mld_l1_fbgs_)
       if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
         write(psb_err_unit,*) &
              & 'MLD2P4: Warning: original coarse solver was requested as ',&

mlprec/impl/mld_dcprecset.F90

@@ -194,89 +194,89 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
           info = -2
           return
         end if
-      if (nlev_ > 1) then 
-        call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
-        select case (val) 
-        case(mld_bjac_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+        if (nlev_ > 1) then 
+          call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
+          select case (val) 
+          case(mld_bjac_,mld_l1_bjac_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
 #if defined(HAVE_UMF_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
 #endif
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
-        case(mld_slu_)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
+          case(mld_slu_)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
-        case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
-        case(mld_mumps_)
+          case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+          case(mld_mumps_)
 #if defined(HAVE_MUMPS_)          
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
-       case(mld_umf_)
+         case(mld_umf_)
 #if defined(HAVE_UMF_)  
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
           
-        case(mld_sludist_)
+          case(mld_sludist_)
 #if defined(HAVE_SLUDIST_) 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #elif defined(HAVE_UMF_)  
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
           case(mld_jac_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
@@ -287,6 +287,18 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
             call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_gs_,mld_fbgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_bwgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_l1_gs_,mld_l1_fbgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
           end select
           
         endif
@@ -345,8 +357,8 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
       if (nlev_ > 1) then 
         call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
         select case (val) 
-        case(mld_bjac_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+        case(mld_bjac_,mld_l1_bjac_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
 #if defined(HAVE_UMF_)
           call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
 #elif defined(HAVE_SLU_)
@@ -435,6 +447,18 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_gs_,mld_fbgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_bwgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_l1_gs_,mld_l1_fbgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
         end select
       endif
 
@@ -609,89 +633,88 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
           info = -2
           return
         end if
-      if (nlev_ > 1) then 
-        call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
-        select case (psb_toupper(trim(string))) 
-        case('BJAC')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+        if (nlev_ > 1) then 
+          call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
+          select case (psb_toupper(trim(string))) 
+          case('BJAC', 'L1-BJAC')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
 #if defined(HAVE_UMF_)
-          call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
 #endif
-          call p%precv(nlev_)%set('COARSE_MAT','dist',info)
-        case('SLU')
+            call p%precv(nlev_)%set('COARSE_MAT','dist',info)
+          case('SLU')
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
-        case('ILU','MILU','ILUT')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
-        case('MUMPS')
+          case('ILU','MILU','ILUT')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+          case('MUMPS')
 #if defined(HAVE_MUMPS_)          
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC'_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
-       case('UMF')
+         case('UMF')
 #if defined(HAVE_UMF_)  
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
-#endif
-          
-        case('SLUDIST')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+#endif          
+          case('SLUDIST')
 #if defined(HAVE_SLUDIST_) 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #elif defined(HAVE_UMF_)  
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
           case('JAC','JACOBI')
             call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
@@ -702,6 +725,18 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
             call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
             call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('GS','FWGS','FBGS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('BWGS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('L1-GS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)          
           end select
           
         endif
@@ -741,9 +776,9 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
     case('COARSE_SOLVE')
       if (nlev_ > 1) then 
         call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
-        select case (string) 
-        case('BJAC')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+        select case (psb_toupper(trim(string)))
+        case('BJAC', 'L1-BJAC')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
 #if defined(HAVE_UMF_)
           call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
 #elif defined(HAVE_SLU_)
@@ -827,11 +862,22 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
           call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE','DIAG',info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
-
         case('L1-JACOBI')
           call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('GS','FWGS','FBGS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('BWGS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('L1-GS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)          
         end select
       endif
 

mlprec/impl/mld_dprecinit.F90

@@ -50,10 +50,15 @@
 !
 !    'DIAG', 'JACOBI' - diagonal/Jacobi           
 !
+!    'L1-DIAG', 'L1-JACOBI' - diagonal/Jacobi  with L1 norm correction
+!
 !    'GS', 'FBGS'     - Hybrid Gauss-Seidel, also symmetrized
 !                       
 !    'BJAC'           - block Jacobi preconditioner, with ILU(0)
 !                       on the local blocks
+!                       
+!    'L1-BJAC'        - block Jacobi preconditioner, with ILU(0)
+!                       on the local blocks and L1 correction for off-diag blocks
 !
 !    'AS'             - Additive Schwarz (AS), with
 !                       overlap 1 and ILU(0) on the local submatrices
@@ -124,7 +129,7 @@ subroutine mld_dprecinit(ictxt,prec,ptype,info)
   prec%ictxt = ictxt
   prec%ag_data%min_coarse_size = -1
 
-  select case(psb_toupper(ptype(1:len_trim(ptype))))
+  select case(psb_toupper(trim(ptype)))
   case ('NOPREC','NONE') 
     nlev_ = 1
     ilev_ = 1
@@ -143,6 +148,15 @@ subroutine mld_dprecinit(ictxt,prec,ptype,info)
     allocate(mld_d_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
     call prec%precv(ilev_)%default()
 
+  case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI') 
+    nlev_ = 1
+    ilev_ = 1
+    allocate(prec%precv(nlev_),stat=info) 
+    allocate(mld_d_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info) 
+    if (info /= psb_success_) return
+    allocate(mld_d_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
+    call prec%precv(ilev_)%default()
+
   case ('GS','FWGS') 
     nlev_ = 1
     ilev_ = 1
@@ -177,6 +191,15 @@ subroutine mld_dprecinit(ictxt,prec,ptype,info)
     allocate(mld_d_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
     call prec%precv(ilev_)%default()
 
+  case ('L1-BJAC','L1_BJAC') 
+    nlev_ = 1
+    ilev_ = 1
+    allocate(prec%precv(nlev_),stat=info) 
+    allocate(mld_d_l1_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info) 
+    if (info /= psb_success_) return
+    allocate(mld_d_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
+    call prec%precv(ilev_)%default()
+
   case ('AS')
     nlev_ = 1
     ilev_ = 1
@@ -207,8 +230,7 @@ subroutine mld_dprecinit(ictxt,prec,ptype,info)
 #else
     call prec%set('COARSE_SOLVE','ILU',info)
 #endif
-    !call prec%precv(nlev_)%default()
-
+    
   case default
     write(psb_err_unit,*) name,&
          &': Warning: Unknown preconditioner type request "',ptype,'"'

mlprec/impl/mld_s_hierarchy_bld.f90

@@ -273,10 +273,12 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
   end if
 
   !
-  ! Finest level first; remember to fix base_a and base_desc
+  ! Finest level first; create a GEN_BLOCK
+  ! copy of the descriptor. 
   ! 
   prec%precv(1)%base_a    => a
-  prec%precv(1)%base_desc => desc_a
+  call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
+  prec%precv(1)%base_desc => prec%precv(1)%desc_ac
   newsz = 0
   array_build_loop: do i=2, iszv
     !
@@ -317,7 +319,7 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
 
     if (debug_level >= psb_debug_outer_) &
          & write(debug_unit,*) me,' ',trim(name),&
-         & 'Return from ',i,' call to mlprcbld ',info      
+         & 'Return from ',i,' call to bld_tprol', info      
     !
     ! Save op_prol just in case
     !
@@ -334,9 +336,9 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
       sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
     end if
     prec%precv(i)%szratio = sizeratio
-    if (iaggsize <= casize) then
-      newsz = i      
-    end if
+
+    if (iaggsize <= casize) newsz = i      
+    if (i == iszv)          newsz = i
 
     if (i>2) then
       if (sizeratio < mnaggratio) then
@@ -440,7 +442,10 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
     ! Restart
     iszv = newsz
     ! Fix the pointers, but the level 1 should
-    ! be already OK
+    ! be treated differently
+    if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
+      prec%precv(1)%base_desc => prec%precv(1)%desc_ac
+    end if
     do i=2, iszv 
       prec%precv(i)%base_a       => prec%precv(i)%ac
       prec%precv(i)%base_desc    => prec%precv(i)%desc_ac
@@ -449,11 +454,6 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
     end do
   end if
 
-  ! Does the coarsening need backfix on descriptors? 
-  do i=2, iszv 
-    if (info == psb_success_) call prec%precv(i)%backfix(prec%precv(i-1),info)    
-  end do
-  
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
          & a_err='Internal hierarchy build' )
@@ -478,7 +478,7 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
 
 contains
   subroutine save_smoothers(level,save1, save2,info)
-    type(mld_s_onelev_type), intent(in) :: level
+    type(mld_s_onelev_type), intent(inout) :: level
     class(mld_s_base_smoother_type), allocatable , intent(inout) :: save1, save2
     integer(psb_ipk_), intent(out) :: info
 
@@ -493,15 +493,19 @@ contains
       if (info  == 0) deallocate(save2,stat=info)
       if (info /= 0) return
     end if
-    allocate(save1, source=level%sm,stat=info) 
-    if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info) 
-
+    allocate(save1, mold=level%sm,stat=info)
+    if (info == 0) call level%sm%clone_settings(save1,info)
+    if ((info == 0).and.allocated(level%sm2a)) then
+      allocate(save2, mold=level%sm2a,stat=info) 
+      if (info == 0) call level%sm2a%clone_settings(save2,info)
+    end if
+    
     return
   end subroutine save_smoothers
 
   subroutine restore_smoothers(level,save1, save2,info)
     type(mld_s_onelev_type), intent(inout), target :: level
-    class(mld_s_base_smoother_type), allocatable, intent(in) :: save1, save2
+    class(mld_s_base_smoother_type), allocatable, intent(inout) :: save1, save2
     integer(psb_ipk_), intent(out) :: info
 
     info  = 0
@@ -511,7 +515,8 @@ contains
       if (info  == 0) deallocate(level%sm,stat=info)
     end if
     if (allocated(save1)) then
-      if (info  == 0) allocate(level%sm,source=save1,stat=info)
+      if (info  == 0) allocate(level%sm,mold=save1,stat=info)
+      if (info == 0) call save1%clone_settings(level%sm,info)
     end if
     
     if (info /= 0) return
@@ -521,7 +526,8 @@ contains
       if (info  == 0) deallocate(level%sm2a,stat=info)
     end if
     if (allocated(save2)) then
-      if (info  == 0) allocate(level%sm2a,source=save2,stat=info)
+      if (info  == 0) allocate(level%sm2a,mold=save2,stat=info)
+      if (info == 0) call save2%clone_settings(level%sm2a,info)
       if (info  == 0) level%sm2 => level%sm2a
     else
       if (allocated(level%sm)) level%sm2 => level%sm

mlprec/impl/mld_s_smoothers_bld.f90

@@ -256,7 +256,7 @@ subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
              & ' but the coarse matrix has been changed to replicated'
       end if
         
-    case(mld_bjac_,mld_jac_, mld_l1_jac_)
+    case(mld_bjac_,mld_l1_bjac_,mld_jac_, mld_l1_jac_, mld_gs_, mld_fbgs_, mld_l1_gs_,mld_l1_fbgs_)
       if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
         write(psb_err_unit,*) &
              & 'MLD2P4: Warning: original coarse solver was requested as ',&

mlprec/impl/mld_scprecset.F90

@@ -188,75 +188,75 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
           info = -2
           return
         end if
-      if (nlev_ > 1) then 
-        call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
-        select case (val) 
-        case(mld_bjac_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+        if (nlev_ > 1) then 
+          call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
+          select case (val) 
+          case(mld_bjac_,mld_l1_bjac_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
 #endif
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
-        case(mld_slu_)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
+          case(mld_slu_)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
-        case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
-        case(mld_mumps_)
+          case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+          case(mld_mumps_)
 #if defined(HAVE_MUMPS_)          
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
-       case(mld_umf_)
+         case(mld_umf_)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
           
-        case(mld_sludist_)
+          case(mld_sludist_)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
           case(mld_jac_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
@@ -267,6 +267,18 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
             call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_gs_,mld_fbgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_bwgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_l1_gs_,mld_l1_fbgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
           end select
           
         endif
@@ -325,8 +337,8 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
       if (nlev_ > 1) then 
         call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
         select case (val) 
-        case(mld_bjac_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+        case(mld_bjac_,mld_l1_bjac_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
 #if defined(HAVE_SLU_)
           call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
@@ -401,6 +413,18 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_gs_,mld_fbgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_bwgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_l1_gs_,mld_l1_fbgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
         end select
       endif
 
@@ -569,75 +593,75 @@ subroutine mld_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
           info = -2
           return
         end if
-      if (nlev_ > 1) then 
-        call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
-        select case (psb_toupper(trim(string))) 
-        case('BJAC')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+        if (nlev_ > 1) then 
+          call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
+          select case (psb_toupper(trim(string))) 
+          case('BJAC', 'L1-BJAC')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
 #endif
-          call p%precv(nlev_)%set('COARSE_MAT','dist',info)
-        case('SLU')
+            call p%precv(nlev_)%set('COARSE_MAT','dist',info)
+          case('SLU')
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
-        case('ILU','MILU','ILUT')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
-        case('MUMPS')
+          case('ILU','MILU','ILUT')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+          case('MUMPS')
 #if defined(HAVE_MUMPS_)          
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC'_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
-       case('UMF')
+         case('UMF')
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
           
-        case('SLUDIST')
+          case('SLUDIST')
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
           case('JAC','JACOBI')
             call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
@@ -648,6 +672,18 @@ subroutine mld_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
             call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
             call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('GS','FWGS','FBGS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('BWGS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('L1-GS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)          
           end select
           
         endif
@@ -687,9 +723,9 @@ subroutine mld_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
     case('COARSE_SOLVE')
       if (nlev_ > 1) then 
         call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
-        select case (string) 
-        case('BJAC')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+        select case (psb_toupper(trim(string)))
+        case('BJAC', 'L1-BJAC')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
 #if defined(HAVE_SLU_)
           call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
@@ -759,11 +795,22 @@ subroutine mld_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
           call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE','DIAG',info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
-
         case('L1-JACOBI')
           call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('GS','FWGS','FBGS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('BWGS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('L1-GS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)          
         end select
       endif
 

mlprec/impl/mld_sprecinit.F90

@@ -50,10 +50,15 @@
 !
 !    'DIAG', 'JACOBI' - diagonal/Jacobi           
 !
+!    'L1-DIAG', 'L1-JACOBI' - diagonal/Jacobi  with L1 norm correction
+!
 !    'GS', 'FBGS'     - Hybrid Gauss-Seidel, also symmetrized
 !                       
 !    'BJAC'           - block Jacobi preconditioner, with ILU(0)
 !                       on the local blocks
+!                       
+!    'L1-BJAC'        - block Jacobi preconditioner, with ILU(0)
+!                       on the local blocks and L1 correction for off-diag blocks
 !
 !    'AS'             - Additive Schwarz (AS), with
 !                       overlap 1 and ILU(0) on the local submatrices
@@ -121,7 +126,7 @@ subroutine mld_sprecinit(ictxt,prec,ptype,info)
   prec%ictxt = ictxt
   prec%ag_data%min_coarse_size = -1
 
-  select case(psb_toupper(ptype(1:len_trim(ptype))))
+  select case(psb_toupper(trim(ptype)))
   case ('NOPREC','NONE') 
     nlev_ = 1
     ilev_ = 1
@@ -140,6 +145,15 @@ subroutine mld_sprecinit(ictxt,prec,ptype,info)
     allocate(mld_s_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
     call prec%precv(ilev_)%default()
 
+  case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI') 
+    nlev_ = 1
+    ilev_ = 1
+    allocate(prec%precv(nlev_),stat=info) 
+    allocate(mld_s_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info) 
+    if (info /= psb_success_) return
+    allocate(mld_s_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
+    call prec%precv(ilev_)%default()
+
   case ('GS','FWGS') 
     nlev_ = 1
     ilev_ = 1
@@ -174,6 +188,15 @@ subroutine mld_sprecinit(ictxt,prec,ptype,info)
     allocate(mld_s_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
     call prec%precv(ilev_)%default()
 
+  case ('L1-BJAC','L1_BJAC') 
+    nlev_ = 1
+    ilev_ = 1
+    allocate(prec%precv(nlev_),stat=info) 
+    allocate(mld_s_l1_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info) 
+    if (info /= psb_success_) return
+    allocate(mld_s_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
+    call prec%precv(ilev_)%default()
+
   case ('AS')
     nlev_ = 1
     ilev_ = 1
@@ -202,8 +225,7 @@ subroutine mld_sprecinit(ictxt,prec,ptype,info)
 #else
     call prec%set('COARSE_SOLVE','ILU',info)
 #endif
-    !call prec%precv(nlev_)%default()
-
+    
   case default
     write(psb_err_unit,*) name,&
          &': Warning: Unknown preconditioner type request "',ptype,'"'

mlprec/impl/mld_z_hierarchy_bld.f90

@@ -273,10 +273,12 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
   end if
 
   !
-  ! Finest level first; remember to fix base_a and base_desc
+  ! Finest level first; create a GEN_BLOCK
+  ! copy of the descriptor. 
   ! 
   prec%precv(1)%base_a    => a
-  prec%precv(1)%base_desc => desc_a
+  call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
+  prec%precv(1)%base_desc => prec%precv(1)%desc_ac
   newsz = 0
   array_build_loop: do i=2, iszv
     !
@@ -317,7 +319,7 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
 
     if (debug_level >= psb_debug_outer_) &
          & write(debug_unit,*) me,' ',trim(name),&
-         & 'Return from ',i,' call to mlprcbld ',info      
+         & 'Return from ',i,' call to bld_tprol', info      
     !
     ! Save op_prol just in case
     !
@@ -334,9 +336,9 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
       sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
     end if
     prec%precv(i)%szratio = sizeratio
-    if (iaggsize <= casize) then
-      newsz = i      
-    end if
+
+    if (iaggsize <= casize) newsz = i      
+    if (i == iszv)          newsz = i
 
     if (i>2) then
       if (sizeratio < mnaggratio) then
@@ -440,7 +442,10 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
     ! Restart
     iszv = newsz
     ! Fix the pointers, but the level 1 should
-    ! be already OK
+    ! be treated differently
+    if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
+      prec%precv(1)%base_desc => prec%precv(1)%desc_ac
+    end if
     do i=2, iszv 
       prec%precv(i)%base_a       => prec%precv(i)%ac
       prec%precv(i)%base_desc    => prec%precv(i)%desc_ac
@@ -449,11 +454,6 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
     end do
   end if
 
-  ! Does the coarsening need backfix on descriptors? 
-  do i=2, iszv 
-    if (info == psb_success_) call prec%precv(i)%backfix(prec%precv(i-1),info)    
-  end do
-  
   if (info /= psb_success_) then 
     call psb_errpush(psb_err_internal_error_,name,&
          & a_err='Internal hierarchy build' )
@@ -478,7 +478,7 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
 
 contains
   subroutine save_smoothers(level,save1, save2,info)
-    type(mld_z_onelev_type), intent(in) :: level
+    type(mld_z_onelev_type), intent(inout) :: level
     class(mld_z_base_smoother_type), allocatable , intent(inout) :: save1, save2
     integer(psb_ipk_), intent(out) :: info
 
@@ -493,15 +493,19 @@ contains
       if (info  == 0) deallocate(save2,stat=info)
       if (info /= 0) return
     end if
-    allocate(save1, source=level%sm,stat=info) 
-    if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info) 
-
+    allocate(save1, mold=level%sm,stat=info)
+    if (info == 0) call level%sm%clone_settings(save1,info)
+    if ((info == 0).and.allocated(level%sm2a)) then
+      allocate(save2, mold=level%sm2a,stat=info) 
+      if (info == 0) call level%sm2a%clone_settings(save2,info)
+    end if
+    
     return
   end subroutine save_smoothers
 
   subroutine restore_smoothers(level,save1, save2,info)
     type(mld_z_onelev_type), intent(inout), target :: level
-    class(mld_z_base_smoother_type), allocatable, intent(in) :: save1, save2
+    class(mld_z_base_smoother_type), allocatable, intent(inout) :: save1, save2
     integer(psb_ipk_), intent(out) :: info
 
     info  = 0
@@ -511,7 +515,8 @@ contains
       if (info  == 0) deallocate(level%sm,stat=info)
     end if
     if (allocated(save1)) then
-      if (info  == 0) allocate(level%sm,source=save1,stat=info)
+      if (info  == 0) allocate(level%sm,mold=save1,stat=info)
+      if (info == 0) call save1%clone_settings(level%sm,info)
     end if
     
     if (info /= 0) return
@@ -521,7 +526,8 @@ contains
       if (info  == 0) deallocate(level%sm2a,stat=info)
     end if
     if (allocated(save2)) then
-      if (info  == 0) allocate(level%sm2a,source=save2,stat=info)
+      if (info  == 0) allocate(level%sm2a,mold=save2,stat=info)
+      if (info == 0) call save2%clone_settings(level%sm2a,info)
       if (info  == 0) level%sm2 => level%sm2a
     else
       if (allocated(level%sm)) level%sm2 => level%sm

mlprec/impl/mld_z_smoothers_bld.f90

@@ -256,7 +256,7 @@ subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
              & ' but the coarse matrix has been changed to replicated'
       end if
         
-    case(mld_bjac_,mld_jac_, mld_l1_jac_)
+    case(mld_bjac_,mld_l1_bjac_,mld_jac_, mld_l1_jac_, mld_gs_, mld_fbgs_, mld_l1_gs_,mld_l1_fbgs_)
       if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
         write(psb_err_unit,*) &
              & 'MLD2P4: Warning: original coarse solver was requested as ',&

mlprec/impl/mld_zcprecset.F90

@@ -194,89 +194,89 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
           info = -2
           return
         end if
-      if (nlev_ > 1) then 
-        call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
-        select case (val) 
-        case(mld_bjac_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+        if (nlev_ > 1) then 
+          call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
+          select case (val) 
+          case(mld_bjac_,mld_l1_bjac_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
 #if defined(HAVE_UMF_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
 #endif
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
-        case(mld_slu_)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
+          case(mld_slu_)
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
-        case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
-        case(mld_mumps_)
+          case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+          case(mld_mumps_)
 #if defined(HAVE_MUMPS_)          
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
-       case(mld_umf_)
+         case(mld_umf_)
 #if defined(HAVE_UMF_)  
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
           
-        case(mld_sludist_)
+          case(mld_sludist_)
 #if defined(HAVE_SLUDIST_) 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #elif defined(HAVE_UMF_)  
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
 #endif
           case(mld_jac_)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
@@ -287,6 +287,18 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
             call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
             call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_gs_,mld_fbgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_bwgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+          case(mld_l1_gs_,mld_l1_fbgs_)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
           end select
           
         endif
@@ -345,8 +357,8 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
       if (nlev_ > 1) then 
         call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
         select case (val) 
-        case(mld_bjac_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+        case(mld_bjac_,mld_l1_bjac_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
 #if defined(HAVE_UMF_)
           call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
 #elif defined(HAVE_SLU_)
@@ -435,6 +447,18 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
           call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_gs_,mld_fbgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_bwgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
+        case(mld_l1_gs_,mld_l1_fbgs_)
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
         end select
       endif
 
@@ -609,89 +633,88 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
           info = -2
           return
         end if
-      if (nlev_ > 1) then 
-        call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
-        select case (psb_toupper(trim(string))) 
-        case('BJAC')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+        if (nlev_ > 1) then 
+          call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
+          select case (psb_toupper(trim(string))) 
+          case('BJAC', 'L1-BJAC')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
 #if defined(HAVE_UMF_)
-          call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
 #else
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
 #endif
-          call p%precv(nlev_)%set('COARSE_MAT','dist',info)
-        case('SLU')
+            call p%precv(nlev_)%set('COARSE_MAT','dist',info)
+          case('SLU')
 #if defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
-        case('ILU','MILU','ILUT')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
-        case('MUMPS')
+          case('ILU','MILU','ILUT')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+          case('MUMPS')
 #if defined(HAVE_MUMPS_)          
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC'_,info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
-       case('UMF')
+         case('UMF')
 #if defined(HAVE_UMF_)  
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
-#endif
-          
-        case('SLUDIST')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+#endif          
+          case('SLUDIST')
 #if defined(HAVE_SLUDIST_) 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #elif defined(HAVE_UMF_)  
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_SLU_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
 #elif defined(HAVE_MUMPS_)
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #else 
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
-          call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
-          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
 #endif
           case('JAC','JACOBI')
             call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
@@ -702,6 +725,18 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
             call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
             call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
             call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('GS','FWGS','FBGS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('BWGS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+          case('L1-GS')
+            call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
+            call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+            call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)          
           end select
           
         endif
@@ -741,9 +776,9 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
     case('COARSE_SOLVE')
       if (nlev_ > 1) then 
         call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
-        select case (string) 
-        case('BJAC')
-          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+        select case (psb_toupper(trim(string)))
+        case('BJAC', 'L1-BJAC')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
 #if defined(HAVE_UMF_)
           call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
 #elif defined(HAVE_SLU_)
@@ -827,11 +862,22 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
           call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE','DIAG',info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
-
         case('L1-JACOBI')
           call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
           call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
           call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('GS','FWGS','FBGS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('BWGS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
+        case('L1-GS')
+          call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
+          call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
+          call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)          
         end select
       endif
 

mlprec/impl/mld_zprecinit.F90

@@ -50,10 +50,15 @@
 !
 !    'DIAG', 'JACOBI' - diagonal/Jacobi           
 !
+!    'L1-DIAG', 'L1-JACOBI' - diagonal/Jacobi  with L1 norm correction
+!
 !    'GS', 'FBGS'     - Hybrid Gauss-Seidel, also symmetrized
 !                       
 !    'BJAC'           - block Jacobi preconditioner, with ILU(0)
 !                       on the local blocks
+!                       
+!    'L1-BJAC'        - block Jacobi preconditioner, with ILU(0)
+!                       on the local blocks and L1 correction for off-diag blocks
 !
 !    'AS'             - Additive Schwarz (AS), with
 !                       overlap 1 and ILU(0) on the local submatrices
@@ -124,7 +129,7 @@ subroutine mld_zprecinit(ictxt,prec,ptype,info)
   prec%ictxt = ictxt
   prec%ag_data%min_coarse_size = -1
 
-  select case(psb_toupper(ptype(1:len_trim(ptype))))
+  select case(psb_toupper(trim(ptype)))
   case ('NOPREC','NONE') 
     nlev_ = 1
     ilev_ = 1
@@ -143,6 +148,15 @@ subroutine mld_zprecinit(ictxt,prec,ptype,info)
     allocate(mld_z_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
     call prec%precv(ilev_)%default()
 
+  case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI') 
+    nlev_ = 1
+    ilev_ = 1
+    allocate(prec%precv(nlev_),stat=info) 
+    allocate(mld_z_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info) 
+    if (info /= psb_success_) return
+    allocate(mld_z_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
+    call prec%precv(ilev_)%default()
+
   case ('GS','FWGS') 
     nlev_ = 1
     ilev_ = 1
@@ -177,6 +191,15 @@ subroutine mld_zprecinit(ictxt,prec,ptype,info)
     allocate(mld_z_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
     call prec%precv(ilev_)%default()
 
+  case ('L1-BJAC','L1_BJAC') 
+    nlev_ = 1
+    ilev_ = 1
+    allocate(prec%precv(nlev_),stat=info) 
+    allocate(mld_z_l1_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info) 
+    if (info /= psb_success_) return
+    allocate(mld_z_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info) 
+    call prec%precv(ilev_)%default()
+
   case ('AS')
     nlev_ = 1
     ilev_ = 1
@@ -207,8 +230,7 @@ subroutine mld_zprecinit(ictxt,prec,ptype,info)
 #else
     call prec%set('COARSE_SOLVE','ILU',info)
 #endif
-    !call prec%precv(nlev_)%default()
-
+    
   case default
     write(psb_err_unit,*) name,&
          &': Warning: Unknown preconditioner type request "',ptype,'"'

mlprec/impl/smoother/Makefile

@@ -12,6 +12,8 @@ mld_c_as_smoother_apply_vect.o \
 mld_c_as_smoother_bld.o \
 mld_c_as_smoother_check.o \
 mld_c_as_smoother_clone.o \
+mld_c_as_smoother_clone_settings.o \
+mld_c_as_smoother_clear_data.o \
 mld_c_as_smoother_cnv.o \
 mld_c_as_smoother_csetc.o \
 mld_c_as_smoother_cseti.o \
@@ -26,6 +28,8 @@ mld_c_base_smoother_apply_vect.o \
 mld_c_base_smoother_bld.o \
 mld_c_base_smoother_check.o \
 mld_c_base_smoother_clone.o \
+mld_c_base_smoother_clone_settings.o \
+mld_c_base_smoother_clear_data.o \
 mld_c_base_smoother_cnv.o \
 mld_c_base_smoother_csetc.o \
 mld_c_base_smoother_cseti.o \
@@ -39,15 +43,22 @@ mld_c_jac_smoother_bld.o \
 mld_c_jac_smoother_descr.o \
 mld_c_jac_smoother_dmp.o \
 mld_c_jac_smoother_clone.o \
+mld_c_jac_smoother_clone_settings.o \
+mld_c_jac_smoother_clear_data.o \
 mld_c_jac_smoother_cnv.o \
 mld_c_jac_smoother_csetc.o \
 mld_c_jac_smoother_cseti.o \
 mld_c_jac_smoother_csetr.o \
+mld_c_l1_jac_smoother_bld.o \
+mld_c_l1_jac_smoother_descr.o \
+mld_c_l1_jac_smoother_clone.o \
 mld_d_as_smoother_apply.o \
 mld_d_as_smoother_apply_vect.o \
 mld_d_as_smoother_bld.o \
 mld_d_as_smoother_check.o \
 mld_d_as_smoother_clone.o \
+mld_d_as_smoother_clone_settings.o \
+mld_d_as_smoother_clear_data.o \
 mld_d_as_smoother_cnv.o \
 mld_d_as_smoother_csetc.o \
 mld_d_as_smoother_cseti.o \
@@ -62,6 +73,8 @@ mld_d_base_smoother_apply_vect.o \
 mld_d_base_smoother_bld.o \
 mld_d_base_smoother_check.o \
 mld_d_base_smoother_clone.o \
+mld_d_base_smoother_clone_settings.o \
+mld_d_base_smoother_clear_data.o \
 mld_d_base_smoother_cnv.o \
 mld_d_base_smoother_csetc.o \
 mld_d_base_smoother_cseti.o \
@@ -75,15 +88,22 @@ mld_d_jac_smoother_bld.o \
 mld_d_jac_smoother_descr.o \
 mld_d_jac_smoother_dmp.o \
 mld_d_jac_smoother_clone.o \
+mld_d_jac_smoother_clone_settings.o \
+mld_d_jac_smoother_clear_data.o \
 mld_d_jac_smoother_cnv.o \
 mld_d_jac_smoother_csetc.o \
 mld_d_jac_smoother_cseti.o \
 mld_d_jac_smoother_csetr.o \
+mld_d_l1_jac_smoother_bld.o \
+mld_d_l1_jac_smoother_descr.o \
+mld_d_l1_jac_smoother_clone.o \
 mld_s_as_smoother_apply.o \
 mld_s_as_smoother_apply_vect.o \
 mld_s_as_smoother_bld.o \
 mld_s_as_smoother_check.o \
 mld_s_as_smoother_clone.o \
+mld_s_as_smoother_clone_settings.o \
+mld_s_as_smoother_clear_data.o \
 mld_s_as_smoother_cnv.o \
 mld_s_as_smoother_csetc.o \
 mld_s_as_smoother_cseti.o \
@@ -98,6 +118,8 @@ mld_s_base_smoother_apply_vect.o \
 mld_s_base_smoother_bld.o \
 mld_s_base_smoother_check.o \
 mld_s_base_smoother_clone.o \
+mld_s_base_smoother_clone_settings.o \
+mld_s_base_smoother_clear_data.o \
 mld_s_base_smoother_cnv.o \
 mld_s_base_smoother_csetc.o \
 mld_s_base_smoother_cseti.o \
@@ -111,15 +133,22 @@ mld_s_jac_smoother_bld.o \
 mld_s_jac_smoother_descr.o \
 mld_s_jac_smoother_dmp.o \
 mld_s_jac_smoother_clone.o \
+mld_s_jac_smoother_clone_settings.o \
+mld_s_jac_smoother_clear_data.o \
 mld_s_jac_smoother_cnv.o \
 mld_s_jac_smoother_csetc.o \
 mld_s_jac_smoother_cseti.o \
 mld_s_jac_smoother_csetr.o \
+mld_s_l1_jac_smoother_bld.o \
+mld_s_l1_jac_smoother_descr.o \
+mld_s_l1_jac_smoother_clone.o \
 mld_z_as_smoother_apply.o \
 mld_z_as_smoother_apply_vect.o \
 mld_z_as_smoother_bld.o \
 mld_z_as_smoother_check.o \
 mld_z_as_smoother_clone.o \
+mld_z_as_smoother_clone_settings.o \
+mld_z_as_smoother_clear_data.o \
 mld_z_as_smoother_cnv.o \
 mld_z_as_smoother_csetc.o \
 mld_z_as_smoother_cseti.o \
@@ -134,6 +163,8 @@ mld_z_base_smoother_apply_vect.o \
 mld_z_base_smoother_bld.o \
 mld_z_base_smoother_check.o \
 mld_z_base_smoother_clone.o \
+mld_z_base_smoother_clone_settings.o \
+mld_z_base_smoother_clear_data.o \
 mld_z_base_smoother_cnv.o \
 mld_z_base_smoother_csetc.o \
 mld_z_base_smoother_cseti.o \
@@ -147,10 +178,15 @@ mld_z_jac_smoother_bld.o \
 mld_z_jac_smoother_descr.o \
 mld_z_jac_smoother_dmp.o \
 mld_z_jac_smoother_clone.o \
+mld_z_jac_smoother_clone_settings.o \
+mld_z_jac_smoother_clear_data.o \
 mld_z_jac_smoother_cnv.o \
 mld_z_jac_smoother_csetc.o \
 mld_z_jac_smoother_cseti.o \
-mld_z_jac_smoother_csetr.o
+mld_z_jac_smoother_csetr.o \
+mld_z_l1_jac_smoother_bld.o \
+mld_z_l1_jac_smoother_descr.o \
+mld_z_l1_jac_smoother_clone.o \
 
 LIBNAME=libmld_prec.a
 

mlprec/impl/smoother/mld_c_as_smoother_apply.f90

@@ -105,116 +105,218 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
     end if
   endif
 
-  if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then 
-    !
-    ! Shortcut: in this case there is nothing else to be done. 
-    !
-    call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) 
+  if (.false.) then 
+    if (sweeps > 0) then 
+      !
+      !
+      ! Apply multiple sweeps of an AS solver
+      ! to compute an approximate solution of a linear system.
+      !
+      !
+      call psb_geasb(tx,sm%desc_data,info)
+      call psb_geasb(ty,sm%desc_data,info)
+      call psb_geasb(ww,sm%desc_data,info)
 
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Error in sub_aply Jacobi Sweeps = 1')
-      goto 9999
-    endif
+      !
+      !  Unroll  the first iteration and fold it inside SELECT CASE
+      !  this will save one SPMM when INIT=Z, and will be
+      !  significant when sweeps=1 (a common case)
+      !
+      select case (init_)
+      case('Z')
+        call psb_geaxpby(cone,x,czero,tx,desc_data,info)    
+        if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
+        call sm%sv%apply(cone,tx,czero,ty,sm%desc_data,trans_,aux,info,init='Z') 
 
-  else if (sweeps >= 0) then 
-    !
-    !
-    ! Apply multiple sweeps of an AS solver
-    ! to compute an approximate solution of a linear system.
-    !
-    !
-    call psb_geasb(tx,sm%desc_data,info)
-    call psb_geasb(ty,sm%desc_data,info)
-    call psb_geasb(ww,sm%desc_data,info)
+      case('Y')
+        call psb_geaxpby(cone,x,czero,tx,desc_data,info)    
+        if (info == 0) call psb_spmm(-cone,sm%pa,y,cone,ww,desc_data,info,&
+             & work=aux,trans=trans_)
+        if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
+        call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y')             
 
-    !
-    !  Unroll  the first iteration and fold it inside SELECT CASE
-    !  this will save one SPMM when INIT=Z, and will be
-    !  significant when sweeps=1 (a common case)
-    !
-    call psb_geaxpby(cone,x,czero,tx,desc_data,info)    
-    if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
-    if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
+      case('U')
+        if (.not.present(initu)) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='missing initu to smoother_apply')
+          goto 9999
+        end if
+        call psb_geaxpby(cone,x,czero,ww,desc_data,info)    
+        call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
+        if (info == 0) call psb_spmm(-cone,sm%pa,ty,cone,ww,desc_data,info,&
+             & work=aux,trans=trans_)
+        if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
+        call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')             
 
-    select case (init_)
-    case('Z')
-      call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Z') 
-
-    case('Y')
-      call psb_geaxpby(cone,y,czero,ty,desc_data,info)
-      if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
-      if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
-           & work=aux,trans=trans_)
-      call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')             
-
-    case('U')
-      if (.not.present(initu)) then
+      case default
         call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='missing initu to smoother_apply')
+             & a_err='wrong  init to smoother_apply')
         goto 9999
-      end if
-      call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
-      if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
-      if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
-           & work=aux,trans=trans_)
-      call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')             
-
-    case default
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='wrong  init to smoother_apply')
-      goto 9999
-    end select
-    if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
-    
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Error in sub_aply Jacobi Sweeps = 1')
-      goto 9999
-    endif
-    
-    do i=1, sweeps-1
-      !
-      ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
-      ! block diagonal part and the remaining part of the local matrix
-      ! and Y(j) is the approximate solution at sweep j.
-      !
-      if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
-      if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
-           & work=aux,trans=trans_)
-      
-      if (info /= psb_success_) exit
-
-      call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y') 
-      
-      if (info /= psb_success_) exit
+      end select
       if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
+
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in sub_aply Jacobi Sweeps = 1')
+        goto 9999
+      endif
+
+      do i=1, sweeps-1
+        !
+        ! Compute Y(j+1) = Y(j)+D^(-1)*(X-A*Y(j)), where D and ND are the
+        ! block diagonal part and the remaining part of the local matrix
+        ! and Y(j) is the approximate solution at sweep j.
+        !
+        if (info == 0) call psb_geaxpby(cone,x,czero,ww,desc_data,info)
+        if (info == 0) call psb_spmm(-cone,sm%pa,ty,cone,ww,desc_data,info,&
+             & work=aux,trans=trans_)
+        
+        if (info /= psb_success_) exit
+        if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
+        call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y') 
+        
+        if (info /= psb_success_) exit
+        if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
+        
+      end do
       
-    end do
+      if (info /= psb_success_) then 
+        info=psb_err_internal_error_
+        call psb_errpush(info,name,&
+             & a_err='subsolve with Jacobi sweeps > 1')
+        goto 9999      
+      end if
 
-    if (info /= psb_success_) then 
-      info=psb_err_internal_error_
+      !
+      ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
+      !
+      call psb_geaxpby(alpha,ty,beta,y,desc_data,info) 
+
+    else  if (sweeps == 0) then
+      !
+      ! 0 sweeps of smoother is the identity operator
+      !
+      call psb_geaxpby(alpha,x,beta,y,desc_data,info)
+      
+    else
+
+      info = psb_err_iarg_neg_
       call psb_errpush(info,name,&
-           & a_err='subsolve with Jacobi sweeps > 1')
-      goto 9999      
-    end if
-    
-    !
-    ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
-    !
-    call psb_geaxpby(alpha,ty,beta,y,desc_data,info) 
-    
-    
+           & i_err=(/itwo,sweeps,izero,izero,izero/))
+      goto 9999
+
+    endif
   else
-    
-    info = psb_err_iarg_neg_
-    call psb_errpush(info,name,&
-         & i_err=(/itwo,sweeps,izero,izero,izero/))
-    goto 9999
+    if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then 
+      !
+      ! Shortcut: in this case there is nothing else to be done. 
+      !
+      call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) 
 
-  endif
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in sub_aply Jacobi Sweeps = 1')
+        goto 9999
+      endif
+
+    else if (sweeps >= 0) then 
+      !
+      !
+      ! Apply multiple sweeps of an AS solver
+      ! to compute an approximate solution of a linear system.
+      !
+      !
+      call psb_geasb(tx,sm%desc_data,info)
+      call psb_geasb(ty,sm%desc_data,info)
+      call psb_geasb(ww,sm%desc_data,info)
+
+      !
+      !  Unroll  the first iteration and fold it inside SELECT CASE
+      !  this will save one SPMM when INIT=Z, and will be
+      !  significant when sweeps=1 (a common case)
+      !
+      call psb_geaxpby(cone,x,czero,tx,desc_data,info)    
+      if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
+      if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
+
+      select case (init_)
+      case('Z')
+        call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Z') 
+
+      case('Y')
+        call psb_geaxpby(cone,y,czero,ty,desc_data,info)
+        if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
+        if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
+             & work=aux,trans=trans_)
+        call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')             
+
+      case('U')
+        if (.not.present(initu)) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='missing initu to smoother_apply')
+          goto 9999
+        end if
+        call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
+        if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
+        if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
+             & work=aux,trans=trans_)
+        call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')             
+
+      case default
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='wrong  init to smoother_apply')
+        goto 9999
+      end select
+      if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
+
+      if (info /= psb_success_) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='Error in sub_aply Jacobi Sweeps = 1')
+        goto 9999
+      endif
+
+      do i=1, sweeps-1
+        !
+        ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
+        ! block diagonal part and the remaining part of the local matrix
+        ! and Y(j) is the approximate solution at sweep j.
+        !
+        if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
+        if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
+             & work=aux,trans=trans_)
+
+        if (info /= psb_success_) exit
+
+        call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y') 
+
+        if (info /= psb_success_) exit
+        if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
+
+      end do
+
+      if (info /= psb_success_) then 
+        info=psb_err_internal_error_
+        call psb_errpush(info,name,&
+             & a_err='subsolve with Jacobi sweeps > 1')
+        goto 9999      
+      end if
+
+      !
+      ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
+      !
+      call psb_geaxpby(alpha,ty,beta,y,desc_data,info) 
+
+
+    else
+
+      info = psb_err_iarg_neg_
+      call psb_errpush(info,name,&
+           & i_err=(/itwo,sweeps,izero,izero,izero/))
+      goto 9999
+
+    endif
+  end if
 
-  
   if (.not.(4*isz <= size(work))) then 
     deallocate(aux,stat=info)
   endif

mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90

@@ -107,89 +107,140 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
     end if
   endif
 
-  if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then 
-    !
-    ! Shortcut: in this case there is nothing else to be done. 
-    !
-    call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) 
-
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,name,&
-           & a_err='Error in sub_aply Jacobi Sweeps = 1')
-      goto 9999
-    endif
-
-  else if (sweeps >= 0) then 
-    !
-    !
-    ! Apply multiple sweeps of an AS solver
-    ! to compute an approximate solution of a linear system.
-    !
-    !
-    if (size(wv) < 3) then 
+  if (.true.) then
+    
+    if (sweeps > 0) then 
+      !
+      !
+      ! Apply multiple sweeps of an AS solver
+      ! to compute an approximate solution of a linear system.
+      !
+      !
+      if (size(wv) < 3) then 
         call psb_errpush(psb_err_internal_error_,name,&
              & a_err='invalid wv size in smoother_apply')
-      goto 9999
-    end if
-    
-    !
-    ! This is tricky. This smoother has a descriptor sm%desc_data
-    ! for an index space potentially different from
-    ! that of desc_data. Hence the size of the work vectors
-    ! could be wrong. We need to check and reallocate as needed.
-    !
-    do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
-         & (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
-         & (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
-    
-    if (do_realloc_wv) then
-      call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
-      call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
-      call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
-    end if
-      
-    associate(tx => wv(1), ty => wv(2), ww => wv(3))
-      
-      ! Need to zero tx because of the apply_restr call.
-      call tx%zero()
-      !
-      !  Unroll  the first iteration and fold it inside SELECT CASE
-      !  this will save one SPMM when INIT=Z, and will be
-      !  significant when sweeps=1 (a common case)
-      !
-      call psb_geaxpby(cone,x,czero,tx,desc_data,info)    
-      if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
-      if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
-
-      select case (init_)
-      case('Z')
-        call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z') 
-
-      case('Y')
-        call psb_geaxpby(cone,y,czero,ty,desc_data,info)
-        if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
-        if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
-             & work=aux,trans=trans_)
-        call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')             
-
-      case('U')
-        if (.not.present(initu)) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='missing initu to smoother_apply')
-          goto 9999
-        end if
-        call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
-        if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
-        if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
-             & work=aux,trans=trans_)
-        call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')             
-
-      case default
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='wrong  init to smoother_apply')
         goto 9999
-      end select
-      if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
+      end if
+
+      !
+      ! This is tricky. This smoother has a descriptor sm%desc_data
+      ! for an index space potentially different from
+      ! that of desc_data. Hence the size of the work vectors
+      ! could be wrong. We need to check and reallocate as needed.
+      !
+      do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
+           & (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
+           & (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
+
+      if (do_realloc_wv) then
+        call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
+        call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
+        call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
+      end if
+
+      associate(tx => wv(1), ty => wv(2), ww => wv(3))
+
+        ! Need to zero tx because of the apply_restr call.
+        call tx%zero()
+        !
+        !  Unroll  the first iteration and fold it inside SELECT CASE
+        !  this will save one SPMM when INIT=Z, and will be
+        !  significant when sweeps=1 (a common case)
+        !
+
+        select case (init_)
+        case('Z')
+          call psb_geaxpby(cone,x,czero,tx,desc_data,info)    
+          if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
+          call sm%sv%apply(cone,tx,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z') 
+
+        case('Y')
+          call psb_geaxpby(cone,x,czero,ww,desc_data,info)    
+          if (info == 0) call psb_spmm(-cone,sm%pa,y,cone,ww,desc_data,info,&
+               & work=aux,trans=trans_)          
+          if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
+          call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')             
+
+        case('U')
+          if (.not.present(initu)) then
+            call psb_errpush(psb_err_internal_error_,name,&
+                 & a_err='missing initu to smoother_apply')
+            goto 9999
+          end if
+          call psb_geaxpby(cone,x,czero,ww,desc_data,info)              
+          call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
+          if (info == 0) call psb_spmm(-cone,sm%pa,ty,cone,ww,desc_data,info,&
+               & work=aux,trans=trans_)          
+          if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
+          call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')             
+
+        case default
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='wrong  init to smoother_apply')
+          goto 9999
+        end select
+        if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
+
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error in sub_aply Jacobi Sweeps = 1')
+          goto 9999
+        endif
+
+        do i=1, sweeps-1
+          !
+          ! Compute Y(j+1) = Y(j)+D^(-1)*(X-A*Y(j)), where D and ND are the
+          ! block diagonal part and the remaining part of the local matrix
+          ! and Y(j) is the approximate solution at sweep j.
+          !
+          if (info == 0) call psb_geaxpby(cone,x,czero,ww,desc_data,info)
+          if (info == 0) call psb_spmm(-cone,sm%pa,ty,cone,ww,desc_data,info,&
+               & work=aux,trans=trans_)
+
+          if (info /= psb_success_) exit
+          if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
+          call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y') 
+
+          if (info /= psb_success_) exit
+          if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
+
+        end do
+
+        if (info /= psb_success_) then 
+          info=psb_err_internal_error_
+          call psb_errpush(info,name,&
+               & a_err='subsolve with Jacobi sweeps > 1')
+          goto 9999      
+        end if
+
+        !
+        ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
+        !
+        call psb_geaxpby(alpha,ty,beta,y,desc_data,info) 
+      end associate
+      
+    else  if (sweeps == 0) then
+      !
+      ! 0 sweeps of smoother is the identity operator
+      !
+      call psb_geaxpby(alpha,x,beta,y,desc_data,info)
+      
+    else
+
+      info = psb_err_iarg_neg_
+      call psb_errpush(info,name,&
+           & i_err=(/itwo,sweeps,izero,izero,izero/))
+      goto 9999
+
+    endif
+
+  else
+
+    if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then 
+      !
+      ! Shortcut: in this case there is nothing else to be done. 
+      !
+      call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) 
 
       if (info /= psb_success_) then
         call psb_errpush(psb_err_internal_error_,name,&
@@ -197,47 +248,125 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
         goto 9999
       endif
 
-      do i=1, sweeps-1
-        !
-        ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
-        ! block diagonal part and the remaining part of the local matrix
-        ! and Y(j) is the approximate solution at sweep j.
-        !
-        if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
-        if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
-             & work=aux,trans=trans_)
-
-        if (info /= psb_success_) exit
-
-        call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y') 
-
-        if (info /= psb_success_) exit
-        if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
-
-      end do
-
-      if (info /= psb_success_) then 
-        info=psb_err_internal_error_
-        call psb_errpush(info,name,&
-             & a_err='subsolve with Jacobi sweeps > 1')
-        goto 9999      
+    else if (sweeps >= 0) then 
+      !
+      !
+      ! Apply multiple sweeps of an AS solver
+      ! to compute an approximate solution of a linear system.
+      !
+      !
+      if (size(wv) < 3) then 
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='invalid wv size in smoother_apply')
+        goto 9999
       end if
 
       !
-      ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
+      ! This is tricky. This smoother has a descriptor sm%desc_data
+      ! for an index space potentially different from
+      ! that of desc_data. Hence the size of the work vectors
+      ! could be wrong. We need to check and reallocate as needed.
       !
-      call psb_geaxpby(alpha,ty,beta,y,desc_data,info) 
-    end associate
+      do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
+           & (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
+           & (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
 
-  else
-    
-    info = psb_err_iarg_neg_
-    call psb_errpush(info,name,&
-         & i_err=(/itwo,sweeps,izero,izero,izero/))
-    goto 9999
+      if (do_realloc_wv) then
+        call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
+        call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
+        call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
+      end if
 
-  endif
+      associate(tx => wv(1), ty => wv(2), ww => wv(3))
 
+        ! Need to zero tx because of the apply_restr call.
+        call tx%zero()
+        !
+        !  Unroll  the first iteration and fold it inside SELECT CASE
+        !  this will save one SPMM when INIT=Z, and will be
+        !  significant when sweeps=1 (a common case)
+        !
+        call psb_geaxpby(cone,x,czero,tx,desc_data,info)    
+        if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
+        if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
+
+        select case (init_)
+        case('Z')
+          call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z') 
+
+        case('Y')
+          call psb_geaxpby(cone,y,czero,ty,desc_data,info)
+          if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
+          if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
+               & work=aux,trans=trans_)
+          call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')             
+
+        case('U')
+          if (.not.present(initu)) then
+            call psb_errpush(psb_err_internal_error_,name,&
+                 & a_err='missing initu to smoother_apply')
+            goto 9999
+          end if
+          call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
+          if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
+          if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
+               & work=aux,trans=trans_)
+          call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')             
+
+        case default
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='wrong  init to smoother_apply')
+          goto 9999
+        end select
+        if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
+
+        if (info /= psb_success_) then
+          call psb_errpush(psb_err_internal_error_,name,&
+               & a_err='Error in sub_aply Jacobi Sweeps = 1')
+          goto 9999
+        endif
+
+        do i=1, sweeps-1
+          !
+          ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
+          ! block diagonal part and the remaining part of the local matrix
+          ! and Y(j) is the approximate solution at sweep j.
+          !
+          if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
+          if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
+               & work=aux,trans=trans_)
+
+          if (info /= psb_success_) exit
+
+          call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y') 
+
+          if (info /= psb_success_) exit
+          if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
+
+        end do
+
+        if (info /= psb_success_) then 
+          info=psb_err_internal_error_
+          call psb_errpush(info,name,&
+               & a_err='subsolve with Jacobi sweeps > 1')
+          goto 9999      
+        end if
+
+        !
+        ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
+        !
+        call psb_geaxpby(alpha,ty,beta,y,desc_data,info) 
+      end associate
+
+    else
+
+      info = psb_err_iarg_neg_
+      call psb_errpush(info,name,&
+           & i_err=(/itwo,sweeps,izero,izero,izero/))
+      goto 9999
+
+    endif
+  end if
   
   if (.not.(4*isz <= size(work))) then 
     deallocate(aux,stat=info)

mlprec/impl/smoother/mld_c_as_smoother_bld.f90

@@ -66,7 +66,7 @@ subroutine mld_c_as_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),' start'
 
-
+  sm%pa  => a
   novr   = sm%novr
   if (novr < 0) then
     info=psb_err_invalid_ovr_num_

mlprec/impl/smoother/mld_c_as_smoother_clear_data.f90

@@ -0,0 +1,70 @@
+!  
+!   
+!                             MLD2P4  version 2.2
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.5)
+!    
+!    (C) Copyright 2008-2018 
+!  
+!        Salvatore Filippone  
+!        Pasqua D'Ambra   
+!        Daniela di Serafino   
+!   
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_as_smoother_clear_data(sm,info)
+  
+  use psb_base_mod
+  use mld_c_as_smoother, mld_protect_name =>  mld_c_as_smoother_clear_data
+  Implicit None
+  ! Arguments
+  class(mld_c_as_smoother_type), intent(inout) :: sm
+  integer(psb_ipk_), intent(out)                   :: info
+  integer(psb_ipk_)  :: err_act
+  character(len=20) :: name='c_as_smoother_clear_data'
+
+  call psb_erractionsave(err_act)
+
+  info = 0
+  call sm%nd%free()
+  sm%nd_nnz_tot = 0 
+  call sm%desc_data%free(info)
+  if ((info==0).and.allocated(sm%sv)) then
+    call sm%sv%clear_data(info)
+  end if
+  if (info /= 0) then
+    info = psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+end subroutine mld_c_as_smoother_clear_data

mlprec/impl/smoother/mld_c_as_smoother_clone.f90

@@ -77,6 +77,7 @@ subroutine mld_c_as_smoother_clone(sm,smout,info)
       allocate(smout%sv,mold=sm%sv,stat=info)
       if (info == psb_success_) call sm%sv%clone(smo%sv,info)
     end if
+    smo%pa => sm%pa
     
   class default
     info = psb_err_internal_error_

mlprec/impl/smoother/mld_c_as_smoother_clone_settings.f90

@@ -0,0 +1,95 @@
+!  
+!   
+!                             MLD2P4  version 2.2
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               asd on PSBLAS (Parallel Sparse BLAS version 3.5)
+!    
+!    (C) Copyright 2008-2018 
+!  
+!        Salvatore Filippone  
+!        Pasqua D'Ambra   
+!        Daniela di Serafino   
+!   
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_as_smoother_clone_settings(sm,smout,info)
+
+  use psb_base_mod
+  use mld_c_as_smoother, mld_protect_name =>  mld_c_as_smoother_clone_settings
+  Implicit None
+  ! Arguments
+  class(mld_c_as_smoother_type), intent(inout)              :: sm
+  class(mld_c_base_smoother_type), intent(inout) :: smout
+  integer(psb_ipk_), intent(out)                 :: info
+  integer(psb_ipk_)  :: err_act
+  character(len=20) :: name='c_as_smoother_clone_settings'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+  
+  select type(smout)
+  class is(mld_c_as_smoother_type)
+    smout%novr  = sm%novr
+    smout%restr = sm%restr
+    smout%prol  = sm%prol
+    if (allocated(smout%sv)) then
+      if (.not.same_type_as(sm%sv,smout%sv)) then
+        call smout%sv%free(info)
+        if (info == 0) deallocate(smout%sv,stat=info)
+      end if
+    end if
+    if (info /= 0) then
+      info = psb_err_internal_error_
+    else
+      if (allocated(smout%sv)) then
+        if (same_type_as(sm%sv,smout%sv)) then
+          call sm%sv%clone_settings(smout%sv,info)
+        else
+          info = psb_err_internal_error_
+        end if
+      else
+        allocate(smout%sv,mold=sm%sv,stat=info)
+        if (info == 0) call sm%sv%clone_settings(smout%sv,info)
+        if (info /= 0) info = psb_err_internal_error_
+      end if
+    end if
+  class default
+    info = psb_err_internal_error_
+  end select
+  
+  if (info /= 0) then
+    call psb_errpush(info,name) 
+    goto 9999
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+end subroutine mld_c_as_smoother_clone_settings

mlprec/impl/smoother/mld_c_as_smoother_dmp.f90

@@ -35,21 +35,22 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+subroutine mld_c_as_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
   
   use psb_base_mod
   use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_dmp
   implicit none 
   class(mld_c_as_smoother_type), intent(in) :: sm
-  integer(psb_ipk_), intent(in)               :: ictxt,level
+  type(psb_desc_type), intent(in)               :: desc
+  integer(psb_ipk_), intent(in)               :: level
   integer(psb_ipk_), intent(out)              :: info
   character(len=*), intent(in), optional :: prefix, head
-  logical, optional, intent(in)    :: smoother, solver
+  logical, optional, intent(in)    :: smoother, solver, global_num
   integer(psb_ipk_)  :: i, j, il1, iln, lname, lev
-  integer(psb_ipk_)  :: icontxt,iam, np
+  integer(psb_ipk_)  :: ictxt,iam, np
   character(len=80)  :: prefix_
   character(len=120) :: fname ! len should be at least 20 more than
-  logical :: smoother_
+  logical :: smoother_, global_num_ 
   !  len of prefix_ 
 
   info = 0
@@ -59,7 +60,7 @@ subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
   else
     prefix_ = "dump_smth_c"
   end if
-
+  ictxt = desc%get_context()
   call psb_info(ictxt,iam,np)
 
   if (present(smoother)) then 
@@ -67,11 +68,18 @@ subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
   else
     smoother_ = .false. 
   end if
+  if (present(global_num)) then 
+    global_num_ = global_num
+  else
+    global_num_ = .false. 
+  end if
   lname = len_trim(prefix_)
   fname = trim(prefix_)
   write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
   lname = lname + 5
-
+  if (global_num_) then
+    write(0,*) iam,' Warning: no global num with AS smoothers dump'
+  end if
   if (smoother_) then 
     write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
     if (sm%nd%is_asb()) &
@@ -79,6 +87,6 @@ subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
   end if
   ! At base level do nothing for the smoother
   if (allocated(sm%sv)) &
-       & call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
+       & call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
 
 end subroutine mld_c_as_smoother_dmp

mlprec/impl/smoother/mld_c_as_smoother_free.f90

@@ -61,6 +61,7 @@ subroutine mld_c_as_smoother_free(sm,info)
     end if
   end if
   call sm%nd%free()
+  sm%pa => null()
 
   call psb_erractionrestore(err_act)
   return

mlprec/impl/smoother/mld_c_base_smoother_clear_data.f90

@@ -0,0 +1,67 @@
+!  
+!   
+!                             MLD2P4  version 2.2
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.5)
+!    
+!    (C) Copyright 2008-2018 
+!  
+!        Salvatore Filippone  
+!        Pasqua D'Ambra   
+!        Daniela di Serafino   
+!   
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_base_smoother_clear_data(sm,info)
+  
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_clear_data
+  Implicit None
+  ! Arguments
+  class(mld_c_base_smoother_type), intent(inout) :: sm
+  integer(psb_ipk_), intent(out)                   :: info
+  integer(psb_ipk_)  :: err_act
+  character(len=20) :: name='c_base_smoother_clear_data'
+
+  call psb_erractionsave(err_act)
+
+  info = 0
+  if (allocated(sm%sv)) then
+    call sm%sv%clear_data(info)
+    if (info /= 0) then
+      info = psb_err_internal_error_
+      call psb_errpush(info,name)
+      goto 9999
+    end if
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+end subroutine mld_c_base_smoother_clear_data

mlprec/impl/smoother/mld_c_base_smoother_clone.f90

@@ -45,7 +45,7 @@ subroutine mld_c_base_smoother_clone(sm,smout,info)
   class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout
   integer(psb_ipk_), intent(out)                 :: info
   integer(psb_ipk_)  :: err_act
-  character(len=20) :: name='d_base_smoother_clone'
+  character(len=20) :: name='c_base_smoother_clone'
 
   call psb_erractionsave(err_act)
 

mlprec/impl/smoother/mld_c_base_smoother_clone_settings.f90

@@ -0,0 +1,89 @@
+!  
+!   
+!                             MLD2P4  version 2.2
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.5)
+!    
+!    (C) Copyright 2008-2018 
+!  
+!        Salvatore Filippone  
+!        Pasqua D'Ambra   
+!        Daniela di Serafino   
+!   
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_base_smoother_clone_settings(sm,smout,info)
+
+  use psb_base_mod
+  use mld_c_base_smoother_mod, mld_protect_name =>  mld_c_base_smoother_clone_settings
+  Implicit None
+  ! Arguments
+  class(mld_c_base_smoother_type), intent(inout)              :: sm
+  class(mld_c_base_smoother_type), intent(inout) :: smout
+  integer(psb_ipk_), intent(out)                 :: info
+  integer(psb_ipk_)  :: err_act
+  character(len=20) :: name='c_base_smoother_clone_settings'
+
+  call psb_erractionsave(err_act)
+
+  info=psb_success_
+  if (same_type_as(sm,smout)) then
+    if (allocated(smout%sv)) then
+      if (.not.same_type_as(sm%sv,smout%sv)) then
+        call smout%sv%free(info)
+        if (info == 0) deallocate(smout%sv,stat=info)
+      end if
+    end if
+    if (info /= 0) then
+      info = psb_err_internal_error_
+    else
+      if (allocated(smout%sv)) then
+        if (same_type_as(sm%sv,smout%sv)) then
+          call sm%sv%clone_settings(smout%sv,info)
+        else
+          info = psb_err_internal_error_
+        end if
+      else
+        allocate(smout%sv,mold=sm%sv,stat=info)
+        if (info == 0) call sm%sv%clone_settings(smout%sv,info)
+        if (info /= 0) info = psb_err_internal_error_
+      end if
+    end if
+  else
+    info = psb_err_internal_error_
+  end if
+  if (info /= 0) then
+    call psb_errpush(info,name) 
+    goto 9999
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+end subroutine mld_c_base_smoother_clone_settings

mlprec/impl/smoother/mld_c_base_smoother_cnv.f90

@@ -48,7 +48,7 @@ subroutine mld_c_base_smoother_cnv(sm,info,amold,vmold,imold)
   class(psb_c_base_vect_type), intent(in), optional  :: vmold
   class(psb_i_base_vect_type), intent(in), optional  :: imold
   integer(psb_ipk_) :: err_act
-  character(len=20) :: name='d_base_smoother_cnv'
+  character(len=20) :: name='c_base_smoother_cnv'
 
   call psb_erractionsave(err_act)
 

mlprec/impl/smoother/mld_c_base_smoother_dmp.f90

@@ -35,21 +35,22 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine mld_c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+subroutine mld_c_base_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
   
   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(psb_ipk_), intent(in)              :: ictxt,level
+  type(psb_desc_type), intent(in)               :: desc
+  integer(psb_ipk_), intent(in)              :: level
   integer(psb_ipk_), intent(out)             :: info
   character(len=*), intent(in), optional :: prefix, head
-  logical, optional, intent(in)    :: smoother, solver
+  logical, optional, intent(in)    :: smoother, solver, global_num
   integer(psb_ipk_)  :: i, j, il1, iln, lname, lev
-  integer(psb_ipk_)  :: icontxt,iam, np
+  integer(psb_ipk_)  :: ictxt,iam, np
   character(len=80)  :: prefix_
   character(len=120) :: fname ! len should be at least 20 more than
-  logical :: smoother_
+  logical :: smoother_, global_num_
   !  len of prefix_ 
 
   info = 0
@@ -59,9 +60,14 @@ subroutine mld_c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solv
   else
     prefix_ = "dump_smth_c"
   end if
-
+  ictxt = desc%get_context()
   call psb_info(ictxt,iam,np)
 
+  if (present(global_num)) then 
+    global_num_ = global_num
+  else
+    global_num_ = .false. 
+  end if
   if (present(smoother)) then 
     smoother_ = smoother
   else
@@ -74,6 +80,6 @@ subroutine mld_c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solv
 
   ! At base level do nothing for the smoother
   if (allocated(sm%sv)) &
-       & call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
+       & call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
 
 end subroutine mld_c_base_smoother_dmp

mlprec/impl/smoother/mld_c_jac_smoother_apply.f90

@@ -65,7 +65,7 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
   ictxt = desc_data%get_context()
   call psb_info(ictxt,me,np)
 
-  
+
   if (present(init)) then
     init_ = psb_toupper(init)
   else
@@ -102,146 +102,63 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
       goto 9999      
     end if
   endif
-  
-  if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then 
-    !  if .not.sv%is_iterative, there's no need to pass init
-    call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) 
-    
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,&
-           & name,a_err='Error in sub_aply Jacobi Sweeps = 1')
+
+  if (sweeps > 0) then 
+    call psb_geasb(tx,desc_data,info)
+    call psb_geasb(ty,desc_data,info)
+    select case (init_)
+    case('Z') 
+
+      call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z') 
+
+    case('Y')
+      call psb_geaxpby(cone,x,czero,tx,desc_data,info)
+      call psb_geaxpby(cone,y,czero,ty,desc_data,info)
+      call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
+      call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') 
+
+    case('U')
+      if (.not.present(initu)) then
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='missing initu to smoother_apply')
+        goto 9999
+      end if
+      call psb_geaxpby(cone,x,czero,tx,desc_data,info)
+      call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
+      call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
+      call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') 
+
+    case default
+      call psb_errpush(psb_err_internal_error_,name,&
+           & a_err='wrong  init to smoother_apply')
       goto 9999
-    endif
-    
-  else if (sweeps >= 0) then 
-    if (associated(sm%pa)) then
+    end select
+
+    do i=1, sweeps-1
       !
-      ! This means we are dealing with a pure Jacobi smoother/solver. 
+      ! Compute Y(j+1) =  Y(j)+ M^(-1)*(X-A*Y(j)),
       !
-      call psb_geasb(tx,desc_data,info)
-      call psb_geasb(ty,desc_data,info)
-      select case (init_)
-      case('Z') 
-        
-        call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z') 
-        
-      case('Y')
-        call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-        call psb_geaxpby(cone,y,czero,ty,desc_data,info)
-        call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-        call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') 
-        
-      case('U')
-        if (.not.present(initu)) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='missing initu to smoother_apply')
-          goto 9999
-        end if
-        call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-        call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
-        call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-        call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') 
-        
-      case default
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='wrong  init to smoother_apply')
-        goto 9999
-      end select
-      
-      do i=1, sweeps-1
-        !
-        ! Compute Y(j+1) =  Y(j)+ D^(-1)*(X-A*Y(j)),
-        !  where is the diagonal and  A the matrix.
-        !
-        call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-        call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-        
-        if (info /= psb_success_) exit
-        
-        call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,info,init='Y') 
-        
-        if (info /= psb_success_) exit
-      end do
-      
-      
-      if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
-      
-      if (info /= psb_success_) then 
-        info=psb_err_internal_error_
-        call psb_errpush(info,name,& 
-             & a_err='subsolve with Jacobi sweeps > 1')
-        goto 9999      
-      end if
-      
-    else
-      !
-      !
-      ! Apply multiple sweeps of a block-Jacobi solver
-      ! to compute an approximate solution of a linear system.
-      !
-      !
-      call psb_geasb(tx,desc_data,info)
-      call psb_geasb(ty,desc_data,info)
+      call psb_geaxpby(cone,x,czero,tx,desc_data,info)
+      call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
 
-      !
-      !  Unroll  the first iteration and fold it inside SELECT CASE
-      !  this will save one AXPBY and one SPMM when INIT=Z, and will be
-      !  significant when sweeps=1 (a common case)
-      !
-      select case (init_)
-      case('Z') 
+      if (info /= psb_success_) exit
 
-        call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z') 
+      call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,info,init='Y') 
 
-      case('Y')
-        call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-        call psb_geaxpby(cone,y,czero,ty,desc_data,info)
-        call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-        call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') 
+      if (info /= psb_success_) exit
+    end do
 
-      case('U')
-        if (.not.present(initu)) then
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='missing initu to smoother_apply')
-          goto 9999
-        end if
-        call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-        call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
-        call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-        call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') 
 
-      case default
-        call psb_errpush(psb_err_internal_error_,name,&
-             & a_err='wrong  init to smoother_apply')
-        goto 9999
-      end select
+    if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
 
-      do i=1, sweeps-1
-        !
-        ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
-        ! block diagonal part and the remaining part of the local matrix
-        ! and Y(j) is the approximate solution at sweep j.
-        !
-        call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-        call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-
-        if (info /= psb_success_) exit
-
-        call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') 
-
-        if (info /= psb_success_) exit
-      end do
-
-      if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
-
-      if (info /= psb_success_) then 
-        info=psb_err_internal_error_
-        call psb_errpush(info,name,& 
-             & a_err='subsolve with Jacobi sweeps > 1')
-        goto 9999      
-      end if
+    if (info /= psb_success_) then 
+      info=psb_err_internal_error_
+      call psb_errpush(info,name,& 
+           & a_err='subsolve with Jacobi sweeps > 1')
+      goto 9999      
     end if
-    
+
+
     deallocate(tx,ty,stat=info)
     if (info /= psb_success_) then 
       info=psb_err_internal_error_
@@ -250,6 +167,12 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
       goto 9999      
     end if
 
+  else  if (sweeps == 0) then
+    !
+    ! 0 sweeps of smoother is the identity operator
+    !
+    call psb_geaxpby(alpha,x,beta,y,desc_data,info)
+
   else
 
     info = psb_err_iarg_neg_

mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90

@@ -49,7 +49,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
   type(psb_c_vect_type),intent(inout)           :: y
   complex(psb_spk_),intent(in)                      :: alpha,beta
   character(len=1),intent(in)                     :: trans
-  integer(psb_ipk_), intent(in)                   :: sweeps
+  integer(psb_ipk_), intent(in)                   :: sweeps 
   complex(psb_spk_),target, intent(inout)           :: work(:)
   type(psb_c_vect_type),intent(inout)           :: wv(:)
   integer(psb_ipk_), intent(out)                  :: info
@@ -108,190 +108,90 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
     end if
   endif
 
-  if(sm%checkres) then
-    call psb_geall(r,desc_data,info)
-    call psb_geasb(r,desc_data,info)
-    resdenum = psb_genrm2(x,desc_data,info)
-  end if
+  if (sweeps > 0) then
 
-  if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then
-    !  if .not.sv%is_iterative, there's no need to pass init
-    call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
+    if(sm%checkres) then
+      call psb_geall(r,desc_data,info)
+      call psb_geasb(r,desc_data,info)
+      resdenum = psb_genrm2(x,desc_data,info)
+    end if
 
-    if (info /= psb_success_) then
-      call psb_errpush(psb_err_internal_error_,&
-           & name,a_err='Error in sub_aply Jacobi Sweeps = 1')
-      goto 9999
-    endif
+    associate(tx => wv(1), ty => wv(2))
+      select case (init_)
+      case('Z')
 
-  else if (sweeps >= 0) then
-    select type (smsv => sm%sv)
-    class is (mld_c_diag_solver_type)
-      !
-      ! This means we are dealing with a pure Jacobi smoother/solver.
-      !
-      associate(tx => wv(1), ty => wv(2))
-        select case (init_)
-        case('Z')
+        call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
 
-          call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
+      case('Y')
+        call psb_geaxpby(cone,x,czero,tx,desc_data,info)
+        call psb_geaxpby(cone,y,czero,ty,desc_data,info)
+        call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
+        call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
 
-        case('Y')
-          call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-          call psb_geaxpby(cone,y,czero,ty,desc_data,info)
-          call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-          call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
-
-        case('U')
-          if (.not.present(initu)) then
-            call psb_errpush(psb_err_internal_error_,name,&
-                 & a_err='missing initu to smoother_apply')
-            goto 9999
-          end if
-          call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-          call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
-          call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-          call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
-
-        case default
+      case('U')
+        if (.not.present(initu)) then
           call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='wrong  init to smoother_apply')
-          goto 9999
-        end select
-
-        do i=1, sweeps-1
-          !
-          ! Compute Y(j+1) =  Y(j)+ D^(-1)*(X-A*Y(j)),
-          !  where is the diagonal and  A the matrix.
-          !
-          call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-          call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-
-          if (info /= psb_success_) exit
-
-          call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
-
-          if (info /= psb_success_) exit
-
-          if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
-            call psb_geaxpby(cone,x,czero,r,r,desc_data,info)
-            call psb_spmm(-cone,sm%pa,ty,cone,r,desc_data,info)
-            res  = psb_genrm2(r,desc_data,info)
-            if( sm%printres ) then
-              call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
-            end if
-            if ( res < sm%tol*resdenum ) then
-              if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) &
-               & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
-              exit
-            end if
-          end if
-
-        end do
-
-
-        if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
-
-        if (info /= psb_success_) then
-          info=psb_err_internal_error_
-          call psb_errpush(info,name,&
-               & a_err='subsolve with Jacobi sweeps > 1')
+               & a_err='missing initu to smoother_apply')
           goto 9999
         end if
+        call psb_geaxpby(cone,x,czero,tx,desc_data,info)
+        call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
+        call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
+        call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
+
+      case default
+        call psb_errpush(psb_err_internal_error_,name,&
+             & a_err='wrong  init to smoother_apply')
+        goto 9999
+      end select
+
+      do i=1, sweeps-1
+        !
+        ! Compute Y(j+1) =  Y(j)+ D^(-1)*(X-A*Y(j)),
+        !  where is the diagonal and  A the matrix.
+        !
+        call psb_geaxpby(cone,x,czero,tx,desc_data,info)
+        call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
+
+        if (info /= psb_success_) exit
+
+        call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
+
+        if (info /= psb_success_) exit
+
+        if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
+          call psb_geaxpby(cone,x,czero,r,r,desc_data,info)
+          call psb_spmm(-cone,sm%pa,ty,cone,r,desc_data,info)
+          res  = psb_genrm2(r,desc_data,info)
+          if( sm%printres ) then
+            call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
+          end if
+          if ( res < sm%tol*resdenum ) then
+            if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) &
+                 & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
+            exit
+          end if
+        end if
+
+      end do
 
 
-      end associate
+      if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
 
-    class default
-      !
-      !
-      ! Apply multiple sweeps of a block-Jacobi solver
-      ! to compute an approximate solution of a linear system.
-      !
-      !
-      if (size(wv) < 2) then
-        info = psb_err_internal_error_
+      if (info /= psb_success_) then
+        info=psb_err_internal_error_
         call psb_errpush(info,name,&
-             & a_err='invalid wv size in smoother_apply')
+             & a_err='subsolve with Jacobi sweeps > 1')
         goto 9999
       end if
-      associate(tx => wv(1), ty => wv(2))
 
-        !
-        !  Unroll  the first iteration and fold it inside SELECT CASE
-        !  this will save one AXPBY and one SPMM when INIT=Z, and will be
-        !  significant when sweeps=1 (a common case)
-        !
-        select case (init_)
-        case('Z')
+    end associate
 
-          call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
-
-        case('Y')
-          call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-          call psb_geaxpby(cone,y,czero,ty,desc_data,info)
-          call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-          call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
-
-        case('U')
-          if (.not.present(initu)) then
-            call psb_errpush(psb_err_internal_error_,name,&
-                 & a_err='missing initu to smoother_apply')
-            goto 9999
-          end if
-          call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-          call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
-          call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-          call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
-
-        case default
-          call psb_errpush(psb_err_internal_error_,name,&
-               & a_err='wrong  init to smoother_apply')
-          goto 9999
-        end select
-
-        do i=1, sweeps-1
-          !
-          ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
-          ! block diagonal part and the remaining part of the local matrix
-          ! and Y(j) is the approximate solution at sweep j.
-          !
-          call psb_geaxpby(cone,x,czero,tx,desc_data,info)
-          call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
-
-          if (info /= psb_success_) exit
-
-          call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
-
-          if (info /= psb_success_) exit
-
-          if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
-            call psb_geaxpby(cone,x,czero,r,r,desc_data,info)
-            call psb_spmm(-cone,sm%pa,ty,cone,r,desc_data,info)
-            res  = psb_genrm2(r,desc_data,info)
-            if( sm%printres ) then
-              call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
-            end if
-            if (res < sm%tol*resdenum ) then
-              if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) &
-                & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
-              exit
-            end if
-          end if
-
-        end do
-
-        if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
-
-        if (info /= psb_success_) then
-          info=psb_err_internal_error_
-          call psb_errpush(info,name,&
-               & a_err='subsolve with Jacobi sweeps > 1')
-          goto 9999
-        end if
-
-      end associate
-    end select
+  else  if (sweeps == 0) then
+    !
+    ! 0 sweeps of smoother is the identity operator
+    !
+    call psb_geaxpby(alpha,x,beta,y,desc_data,info)
 
   else
 

mlprec/impl/smoother/mld_c_jac_smoother_bld.f90

@@ -51,9 +51,8 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
   class(psb_c_base_vect_type), intent(in), optional  :: vmold
   class(psb_i_base_vect_type), intent(in), optional  :: imold
   ! Local variables
+  type(psb_cspmat_type) :: tmpa
   integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
-  complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
-  type(psb_c_coo_sparse_mat) :: tmpcoo
   integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
   character(len=20) :: name='c_jac_smoother_bld', ch_err
 
@@ -72,19 +71,23 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
   nrow_a = a%get_nrows()
   nztota = a%get_nzeros()
 
-  if( sm%checkres ) sm%pa => a
+  sm%pa => a
 
   select type (smsv => sm%sv)
   class is (mld_c_diag_solver_type)
     call sm%nd%free()
-    sm%pa => a
     sm%nd_nnz_tot = nztota
+    call psb_sum(ictxt,sm%nd_nnz_tot)
+    call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
 
   class default
     if (smsv%is_global()) then
       ! Do not put anything into SM%ND since the solver
       ! is acting globally.
+      call sm%nd%free()
       sm%nd_nnz_tot = 0
+      call psb_sum(ictxt,sm%nd_nnz_tot)
+      call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
     else
       call a%csclip(sm%nd,info,&
            & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
@@ -98,6 +101,10 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
         endif
       end if
       sm%nd_nnz_tot = sm%nd%get_nzeros()
+      call psb_sum(ictxt,sm%nd_nnz_tot)
+      call a%csclip(tmpa,info,&
+           & jmax=nrow_a,rscale=.false.,cscale=.false.)
+      call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold)
     end if
   end select
   if (info /= psb_success_) then
@@ -105,15 +112,7 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
          & a_err='clip & psb_spcnv csr 4')
     goto 9999
   end if
-  call psb_sum(ictxt,sm%nd_nnz_tot)
 
-
-  call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,&
-         & a_err='solver build')
-    goto 9999
-  end if
   if (debug_level >= psb_debug_outer_) &
        & write(debug_unit,*) me,' ',trim(name),' end'
 

mlprec/impl/smoother/mld_c_jac_smoother_clear_data.f90

@@ -0,0 +1,70 @@
+!  
+!   
+!                             MLD2P4  version 2.2
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.5)
+!    
+!    (C) Copyright 2008-2018 
+!  
+!        Salvatore Filippone  
+!        Pasqua D'Ambra   
+!        Daniela di Serafino   
+!   
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_jac_smoother_clear_data(sm,info)
+  
+  use psb_base_mod
+  use mld_c_jac_smoother, mld_protect_name =>  mld_c_jac_smoother_clear_data
+  Implicit None
+  ! Arguments
+  class(mld_c_jac_smoother_type), intent(inout) :: sm
+  integer(psb_ipk_), intent(out)                   :: info
+  integer(psb_ipk_)  :: err_act
+  character(len=20) :: name='c_jac_smoother_clear_data'
+
+  call psb_erractionsave(err_act)
+
+  info = 0
+  call sm%nd%free()
+  sm%nd_nnz_tot = 0
+  sm%pa         => null()
+  if ((info==0).and.allocated(sm%sv)) then
+    call sm%sv%clear_data(info)
+  end if
+  if (info /= 0) then
+    info = psb_err_internal_error_
+    call psb_errpush(info,name)
+    goto 9999
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+end subroutine mld_c_jac_smoother_clear_data

mlprec/impl/smoother/mld_c_jac_smoother_clone.f90

@@ -1,15 +1,15 @@
-!  
-!   
+!
+!
 !                             MLD2P4  version 2.2
 !    MultiLevel Domain Decomposition Parallel Preconditioners Package
 !               based on PSBLAS (Parallel Sparse BLAS version 3.5)
-!    
-!    (C) Copyright 2008-2018 
-!  
-!        Salvatore Filippone  
-!        Pasqua D'Ambra   
-!        Daniela di Serafino   
-!   
+!
+!    (C) Copyright 2008-2018
+!
+!        Salvatore Filippone
+!        Pasqua D'Ambra
+!        Daniela di Serafino
+!
 !    Redistribution and use in source and binary forms, with or without
 !    modification, are permitted provided that the following conditions
 !    are met:
@@ -21,7 +21,7 @@
 !      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
@@ -33,10 +33,10 @@
 !    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_c_jac_smoother_clone(sm,smout,info)
-  
+
   use psb_base_mod
   use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_clone
 
@@ -59,19 +59,25 @@ subroutine mld_c_jac_smoother_clone(sm,smout,info)
   end if
   if (info == psb_success_) &
        & allocate(mld_c_jac_smoother_type :: smout, stat=info)
-  if (info /= 0) then 
+  if (info /= 0) then
     info = psb_err_alloc_dealloc_
-    goto 9999 
+    goto 9999
   end if
 
   select type(smo => smout)
   type is (mld_c_jac_smoother_type)
     smo%nd_nnz_tot = sm%nd_nnz_tot
+    smo%checkres   = sm%checkres
+    smo%printres   = sm%printres
+    smo%checkiter  = sm%checkiter
+    smo%printiter  = sm%printiter
+    smo%tol        = sm%tol
     call sm%nd%clone(smo%nd,info)
     if ((info==psb_success_).and.(allocated(sm%sv))) then
       allocate(smout%sv,mold=sm%sv,stat=info)
       if (info == psb_success_) call sm%sv%clone(smo%sv,info)
     end if
+    smo%pa => sm%pa
 
   class default
     info = psb_err_internal_error_

mlprec/impl/smoother/mld_c_jac_smoother_clone_settings.f90

@@ -0,0 +1,101 @@
+!  
+!   
+!                             MLD2P4  version 2.2
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               asd on PSBLAS (Parallel Sparse BLAS version 3.5)
+!    
+!    (C) Copyright 2008-2018 
+!  
+!        Salvatore Filippone  
+!        Pasqua D'Ambra   
+!        Daniela di Serafino   
+!   
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_jac_smoother_clone_settings(sm,smout,info)
+
+  use psb_base_mod
+  use mld_c_jac_smoother, mld_protect_name =>  mld_c_jac_smoother_clone_settings
+  Implicit None
+  ! Arguments
+  class(mld_c_jac_smoother_type), intent(inout)              :: sm
+  class(mld_c_base_smoother_type), intent(inout) :: smout
+  integer(psb_ipk_), intent(out)                 :: info
+  integer(psb_ipk_)  :: err_act
+  character(len=20) :: name='c_jac_smoother_clone_settings'
+
+  call psb_erractionsave(err_act)
+
+  info = psb_success_
+  
+  select type(smout)
+  class is(mld_c_jac_smoother_type)
+
+    smout%pa => null()
+    smout%nd_nnz_tot = 0
+    smout%checkres   = sm%checkres
+    smout%printres   = sm%printres
+    smout%checkiter  = sm%checkiter
+    smout%printiter  = sm%printiter
+    smout%tol        = sm%tol
+
+    if (allocated(smout%sv)) then
+      if (.not.same_type_as(sm%sv,smout%sv)) then
+        call smout%sv%free(info)
+        if (info == 0) deallocate(smout%sv,stat=info)
+      end if
+    end if
+    if (info /= 0) then
+      info = psb_err_internal_error_
+    else
+      if (allocated(smout%sv)) then
+        if (same_type_as(sm%sv,smout%sv)) then
+          call sm%sv%clone_settings(smout%sv,info)
+        else
+          info = psb_err_internal_error_
+        end if
+      else
+        allocate(smout%sv,mold=sm%sv,stat=info)
+        if (info == 0) call sm%sv%clone_settings(smout%sv,info)
+        if (info /= 0) info = psb_err_internal_error_
+      end if
+    end if
+  class default
+    info = psb_err_internal_error_
+  end select
+  
+  if (info /= 0) then
+    call psb_errpush(info,name) 
+    goto 9999
+  end if
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+end subroutine mld_c_jac_smoother_clone_settings

mlprec/impl/smoother/mld_c_jac_smoother_cnv.f90

@@ -59,7 +59,7 @@ subroutine mld_c_jac_smoother_cnv(sm,info,amold,vmold,imold)
 
 
   if (info == psb_success_) then
-    if ((.not.associated(sm%pa)).and.(sm%nd%is_asb())) then
+    if (sm%nd%is_asb()) then
       if (present(amold)) then 
         call sm%nd%cscnv(info,&
              & mold=amold,dupl=psb_dupl_add_)

mlprec/impl/smoother/mld_c_jac_smoother_csetc.f90

@@ -52,22 +52,27 @@ subroutine mld_c_jac_smoother_csetc(sm,what,val,info,idx)
   info = psb_success_
   call psb_erractionsave(err_act)
 
-
-  select case(psb_toupper(what))
-  case('SMOOTHER_STOP')
-    if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then
-      sm%checkres   = .true.
-    else
-      sm%checkres   = .false.
-    end if
-  case('SMOOTHER_TRACE')
-    if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then
-      sm%printres   = .true.
-    else
-      sm%printres   = .false.
-    end if
-  case default
-    call sm%mld_c_base_smoother_type%set(what,val,info,idx=idx)
+  select case(psb_toupper(trim(what)))
+    case('SMOOTHER_STOP')
+      select case(psb_toupper(trim(val)))
+      case('T','TRUE')
+        sm%checkres   = .true.
+      case('F','FALSE')
+        sm%checkres   = .false.
+      case default
+        write(0,*) 'Unknown value for smoother_stop : "',psb_toupper(trim(val)),'"'
+      end select
+    case('SMOOTHER_TRACE')
+      select case(psb_toupper(trim(val)))
+      case('T','TRUE')
+        sm%printres   = .true.
+      case('F','FALSE')
+        sm%printres   = .false.
+      case default
+        write(0,*) 'Unknown value for smoother_trace : "',psb_toupper(trim(val)),'"'
+      end select
+    case default
+      call sm%mld_c_base_smoother_type%set(what,val,info,idx=idx)
   end select
 
   if (info /= psb_success_) then

mlprec/impl/smoother/mld_c_jac_smoother_dmp.f90

@@ -35,21 +35,23 @@
 !    POSSIBILITY OF SUCH DAMAGE.
 !   
 !  
-subroutine mld_c_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
+subroutine mld_c_jac_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
   
   use psb_base_mod
   use mld_c_jac_smoother, mld_protect_nam => mld_c_jac_smoother_dmp
   implicit none 
   class(mld_c_jac_smoother_type), intent(in) :: sm
-  integer(psb_ipk_), intent(in)               :: ictxt,level
+  type(psb_desc_type), intent(in)               :: desc
+  integer(psb_ipk_), intent(in)               :: level
   integer(psb_ipk_), intent(out)              :: info
   character(len=*), intent(in), optional :: prefix, head
-  logical, optional, intent(in)    :: smoother, solver
+  logical, optional, intent(in)    :: smoother, solver, global_num
   integer(psb_ipk_)  :: i, j, il1, iln, lname, lev
-  integer(psb_ipk_)  :: icontxt,iam, np
+  integer(psb_ipk_)  :: ictxt,iam, np
   character(len=80)  :: prefix_
   character(len=120) :: fname ! len should be at least 20 more than
-  logical :: smoother_
+  integer(psb_lpk_), allocatable :: iv(:)
+  logical :: smoother_, global_num_
   !  len of prefix_ 
 
   info = 0
@@ -59,7 +61,7 @@ subroutine mld_c_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solve
   else
     prefix_ = "dump_smth_c"
   end if
-
+  ictxt = desc%get_context()
   call psb_info(ictxt,iam,np)
 
   if (present(smoother)) then 
@@ -67,6 +69,11 @@ subroutine mld_c_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solve
   else
     smoother_ = .false. 
   end if
+  if (present(global_num)) then 
+    global_num_ = global_num
+  else
+    global_num_ = .false. 
+  end if
   lname = len_trim(prefix_)
   fname = trim(prefix_)
   write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
@@ -74,11 +81,17 @@ subroutine mld_c_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solve
 
   if (smoother_) then 
     write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
-    if (sm%nd%is_asb()) &
-         & call sm%nd%print(fname,head=head)
+    if (global_num_) then
+      iv = desc%get_global_indices(owned=.false.)      
+      if (sm%nd%is_asb()) &
+           & call sm%nd%print(fname,head=head,iv=iv)
+    else
+      if (sm%nd%is_asb()) &
+           & call sm%nd%print(fname,head=head)
+    end if
   end if
   ! At base level do nothing for the smoother
   if (allocated(sm%sv)) &
-       & call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
+       & call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
 
 end subroutine mld_c_jac_smoother_dmp

mlprec/impl/smoother/mld_c_l1_jac_smoother_bld.f90

@@ -0,0 +1,175 @@
+!
+!
+!                             MLD2P4  version 2.2
+!    MultiLevel Domain Decomposition Parallel Preconditioners Package
+!               based on PSBLAS (Parallel Sparse BLAS version 3.5)
+!
+!    (C) Copyright 2008-2018
+!
+!        Salvatore Filippone
+!        Pasqua D'Ambra
+!        Daniela di Serafino
+!
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions, and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+!      3. The name of the 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_c_l1_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
+
+  use psb_base_mod
+  use mld_c_diag_solver
+  use mld_c_jac_smoother, mld_protect_name => mld_c_l1_jac_smoother_bld
+  Implicit None
+
+  ! Arguments
+  type(psb_cspmat_type), intent(in), target          :: a
+  Type(psb_desc_type), Intent(inout)                 :: desc_a
+  class(mld_c_l1_jac_smoother_type), intent(inout)      :: sm
+  integer(psb_ipk_), intent(out)                     :: info
+  class(psb_c_base_sparse_mat), intent(in), optional :: amold
+  class(psb_c_base_vect_type), intent(in), optional  :: vmold
+  class(psb_i_base_vect_type), intent(in), optional  :: imold
+  ! Local variables
+  integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
+  real(psb_spk_), allocatable  :: arwsum(:)
+  type(psb_cspmat_type)      :: tmpa
+  integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
+  character(len=20) :: name='c_l1_jac_smoother_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()
+  n_col  = desc_a%get_local_cols()
+  nrow_a = a%get_nrows()
+  nztota = a%get_nzeros()
+
+  sm%pa => a
+
+  select type (smsv => sm%sv)
+  class is (mld_c_diag_solver_type)
+    call sm%nd%free()
+    sm%nd_nnz_tot = nztota
+    
+    call psb_sum(ictxt,sm%nd_nnz_tot)
+    call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
+
+  class default
+    if (smsv%is_global()) then
+      ! Do not put anything into SM%ND since the solver
+      ! is acting globally.
+      call sm%nd%free()
+      sm%nd_nnz_tot = 0
+      call psb_sum(ictxt,sm%nd_nnz_tot)
+      call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
+    else
+
+      call a%csclip(tmpa,info,&
+           & jmax=nrow_a,rscale=.false.,cscale=.false.)
+      
+      call a%csclip(sm%nd,info,&
+           & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
+      
+      arwsum = sm%nd%arwsum(info)
+      
+      call combine_dl1(-sone,arwsum,sm%nd,info)
+      call combine_dl1(sone,arwsum,tmpa,info)
+      
+      sm%nd_nnz_tot = sm%nd%get_nzeros()
+      call psb_sum(ictxt,sm%nd_nnz_tot)
+
+      call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold)
+
+      if (info == psb_success_) then
+        if (present(amold)) then
+          call sm%nd%cscnv(info,&
+               & mold=amold,dupl=psb_dupl_add_)
+        else
+          call sm%nd%cscnv(info,&
+               & type='csr',dupl=psb_dupl_add_)
+        endif
+      end if
+    end if
+  end select
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_from_subroutine_,name,&
+         & a_err='clip & psb_spcnv csr 4')
+    goto 9999
+  end if
+
+
+  if (info /= psb_success_) then
+    call psb_errpush(psb_err_from_subroutine_,name,&
+         & a_err='solver build')
+    goto 9999
+  end if
+  if (debug_level >= psb_debug_outer_) &
+       & write(debug_unit,*) me,' ',trim(name),' end'
+
+  call psb_erractionrestore(err_act)
+  return
+
+9999 call psb_error_handler(err_act)
+
+  return
+  
+contains
+  
+  subroutine combine_dl1(alpha,dl1,mat,info)
+    implicit none
+    real(psb_spk_), intent(in) ::  alpha, dl1(:)
+    type(psb_cspmat_type), intent(inout) :: mat
+    integer(psb_ipk_), intent(out) :: info 
+    !
+    integer(psb_ipk_) :: k, nz, nrm, dp
+    type(psb_c_coo_sparse_mat) :: tcoo
+
+    call mat%mv_to(tcoo)
+    nz = tcoo%get_nzeros()
+    nrm = min(size(dl1),tcoo%get_nrows(),tcoo%get_ncols())
+!!$    write(0,*) 'Check on combine_dl1: ',nrm, tcoo%get_nrows(),tcoo%get_ncols(), nz
+    call tcoo%ensure_size(nz+nrm)
+    call tcoo%set_dupl(psb_dupl_add_)
+    do k=1,nrm
+      if (dl1(k) /= szero) then
+        nz = nz + 1
+        tcoo%ia(nz)  = k
+        tcoo%ja(nz)  = k
+        tcoo%val(nz) = alpha*dl1(k)
+      end if
+    end do
+    call tcoo%set_nzeros(nz)
+    call tcoo%fix(info)
+    call mat%mv_from(tcoo)
+  end subroutine combine_dl1
+
+
+end subroutine mld_c_l1_jac_smoother_bld