Fix AMG cbind interface

amgprec/amg_c_base_aggregator_mod.f90

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

amgprec/amg_c_inner_mod.f90

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

amgprec/amg_c_onelev_mod.f90

@@ -154,35 +154,13 @@ module amg_c_onelev_mod
   private :: c_wrk_alloc, c_wrk_free, &
        & c_wrk_clone, c_wrk_move_alloc, c_wrk_cnv, c_wrk_sizeof
 
-  !
-  ! Remap.
-  !  This keeps track of remapping.
-  !  Logic here is as follows:
-  !  1. AC_PRE_REMAP  need to figure out if we
-  !                really need it.
-  !  2. DESC_AC_PRE_REMAP  contains the descriptor before
-  !                remapping. Meaning that it is possible
-  !                to implement the RESTRICTOR operator by
-  !                 a. Doing LINMAP_U2V onto this one
-  !                 b. For each process, send the data to
-  !                    IDEST.
-  !                This assumes that remapping goes by
-  !                a factor of 2.
-  !                For the PROLONGATOR operators, we first
-  !                use DESC_AC, then split and send onto
-  !                the processes in DESC_AC_PRE_REMAP.
-  !
-  ! To be fixed: what happens if NP the starting processes
-  ! is not an even number? Coordinate with _X_remap in PSBLAS
-  ! 
   type amg_c_remap_data_type
     type(psb_cspmat_type)          :: ac_pre_remap
     type(psb_desc_type)            :: desc_ac_pre_remap
     integer(psb_ipk_)              :: idest
     integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
   contains
-    procedure, pass(rmp) :: clone      => c_remap_data_clone
-    procedure, pass(rmp) :: move_alloc => c_remap_move_alloc
+    procedure, pass(rmp) :: clone   => c_remap_data_clone
   end type amg_c_remap_data_type
 
   type amg_c_onelev_type
@@ -228,7 +206,7 @@ module amg_c_onelev_mod
     procedure, pass(lv) :: get_wrksz => c_base_onelev_get_wrksize
     procedure, pass(lv) :: allocate_wrk   => c_base_onelev_allocate_wrk
     procedure, pass(lv) :: free_wrk       => c_base_onelev_free_wrk
-    procedure, nopass   :: stringval  => amg_stringval
+    procedure, nopass   :: stringval => amg_stringval
     procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc
 
 
@@ -640,7 +618,7 @@ contains
     ! Arguments
     class(amg_c_onelev_type), target, intent(inout) :: lv
     class(amg_c_onelev_type), target, intent(inout) :: lvout
-    integer(psb_ipk_), intent(out)                  :: info
+    integer(psb_ipk_), intent(out)                    :: info
 
     info = psb_success_
     if (allocated(lv%sm)) then
@@ -706,7 +684,6 @@ contains
     if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
     if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
     if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
-    if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
     b%base_a    => lv%base_a
     b%base_desc => lv%base_desc
 
@@ -761,7 +738,6 @@ contains
     info = psb_success_
     nwv = lv%get_wrksz()
     if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
-!!$    write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
     if (info == 0) then
       if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
         !
@@ -809,32 +785,47 @@ contains
 
     info = psb_success_
     call wk%free(info)
-!!$    write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
-!!$         & present(desc2),desc%is_valid()
-
-    allocate(wk%wv(nwv),stat=info)    
-    if  (present(desc2).and.(desc%is_valid())) then
-!!$      write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
+    if  (present(desc2)) then
+!!$      write(0,*) 'Check on wrk_alloc 2',&
+!!$           & desc2%get_local_rows(), desc%get_local_rows(),&
+!!$           & desc2%get_local_cols(),desc%get_local_cols()
+!!$      flush(0)
       if (desc2%get_local_cols()>desc%get_local_cols()) then
-        call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
+        call psb_geasb(wk%vx2l,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vy2l,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vtx,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vty,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        allocate(wk%wv(nwv),stat=info)
+        do i=1,nwv
+          call psb_geasb(wk%wv(i),desc2,info,&
+               & scratch=.true.,mold=vmold)
+        end do
       else
-        call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
+!!$        write(0,*) 'Check on wrk_alloc 1.5 ',&
+!!$             & desc%get_local_rows(),&
+!!$             & desc%get_local_cols()
+        call psb_geasb(wk%vx2l,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vy2l,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vtx,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vty,desc,info,&
+             & scratch=.true.,mold=vmold)
+        allocate(wk%wv(nwv),stat=info)
+        do i=1,nwv
+          call psb_geasb(wk%wv(i),desc,info,&
+               & scratch=.true.,mold=vmold)
+        end do
       end if
-    else if (present(desc2)) then
-      call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
-    else if (desc%is_valid()) then
-      call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)      
-    end if
-
-  contains
-    subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold)
-      class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
-      integer(psb_ipk_), intent(in)                     :: nwv
-      type(psb_desc_type), intent(in)                   :: desc
-      class(psb_c_base_vect_type), intent(in), optional  :: vmold
-      
-      integer(psb_ipk_) :: i
-      
+    else
+!!$      write(0,*) 'Check on wrk_alloc 1 ',&
+!!$           & desc%get_local_rows(),&
+!!$           & desc%get_local_cols()
       call psb_geasb(wk%vx2l,desc,info,&
            & scratch=.true.,mold=vmold)
       call psb_geasb(wk%vy2l,desc,info,&
@@ -843,11 +834,12 @@ contains
            & scratch=.true.,mold=vmold)
       call psb_geasb(wk%vty,desc,info,&
            & scratch=.true.,mold=vmold)
+      allocate(wk%wv(nwv),stat=info)
       do i=1,nwv
         call psb_geasb(wk%wv(i),desc,info,&
              & scratch=.true.,mold=vmold)
       end do
-    end subroutine inner_do_wrk_alloc
+    end if
   end subroutine c_wrk_alloc
 
   subroutine c_wrk_free(wk,info)
@@ -1000,25 +992,4 @@ contains
     call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
   end subroutine c_remap_data_clone
 
-  subroutine c_remap_move_alloc(rmp, remap_out, info)
-    use psb_base_mod
-    implicit none
-    ! Arguments
-    class(amg_c_remap_data_type), target, intent(inout) :: rmp
-    class(amg_c_remap_data_type), target, intent(inout) :: remap_out
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-
-    call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
-    if (info == psb_success_) &
-         & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
-    remap_out%idest = rmp%idest
-    call move_alloc(rmp%isrc,remap_out%isrc)
-    call move_alloc(rmp%nrsrc,remap_out%nrsrc)
-    call move_alloc(rmp%naggr,remap_out%naggr)
-  end subroutine c_remap_move_alloc
-  
 end module amg_c_onelev_mod

amgprec/amg_c_prec_type.f90

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

amgprec/amg_d_base_aggregator_mod.f90

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

amgprec/amg_d_inner_mod.f90

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

amgprec/amg_d_onelev_mod.f90

@@ -155,35 +155,13 @@ module amg_d_onelev_mod
   private :: d_wrk_alloc, d_wrk_free, &
        & d_wrk_clone, d_wrk_move_alloc, d_wrk_cnv, d_wrk_sizeof
 
-  !
-  ! Remap.
-  !  This keeps track of remapping.
-  !  Logic here is as follows:
-  !  1. AC_PRE_REMAP  need to figure out if we
-  !                really need it.
-  !  2. DESC_AC_PRE_REMAP  contains the descriptor before
-  !                remapping. Meaning that it is possible
-  !                to implement the RESTRICTOR operator by
-  !                 a. Doing LINMAP_U2V onto this one
-  !                 b. For each process, send the data to
-  !                    IDEST.
-  !                This assumes that remapping goes by
-  !                a factor of 2.
-  !                For the PROLONGATOR operators, we first
-  !                use DESC_AC, then split and send onto
-  !                the processes in DESC_AC_PRE_REMAP.
-  !
-  ! To be fixed: what happens if NP the starting processes
-  ! is not an even number? Coordinate with _X_remap in PSBLAS
-  ! 
   type amg_d_remap_data_type
     type(psb_dspmat_type)          :: ac_pre_remap
     type(psb_desc_type)            :: desc_ac_pre_remap
     integer(psb_ipk_)              :: idest
     integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
   contains
-    procedure, pass(rmp) :: clone      => d_remap_data_clone
-    procedure, pass(rmp) :: move_alloc => d_remap_move_alloc
+    procedure, pass(rmp) :: clone   => d_remap_data_clone
   end type amg_d_remap_data_type
 
   type amg_d_onelev_type
@@ -229,7 +207,7 @@ module amg_d_onelev_mod
     procedure, pass(lv) :: get_wrksz => d_base_onelev_get_wrksize
     procedure, pass(lv) :: allocate_wrk   => d_base_onelev_allocate_wrk
     procedure, pass(lv) :: free_wrk       => d_base_onelev_free_wrk
-    procedure, nopass   :: stringval  => amg_stringval
+    procedure, nopass   :: stringval => amg_stringval
     procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc
 
 
@@ -641,7 +619,7 @@ contains
     ! Arguments
     class(amg_d_onelev_type), target, intent(inout) :: lv
     class(amg_d_onelev_type), target, intent(inout) :: lvout
-    integer(psb_ipk_), intent(out)                  :: info
+    integer(psb_ipk_), intent(out)                    :: info
 
     info = psb_success_
     if (allocated(lv%sm)) then
@@ -707,7 +685,6 @@ contains
     if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
     if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
     if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
-    if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
     b%base_a    => lv%base_a
     b%base_desc => lv%base_desc
 
@@ -762,7 +739,6 @@ contains
     info = psb_success_
     nwv = lv%get_wrksz()
     if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
-!!$    write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
     if (info == 0) then
       if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
         !
@@ -810,32 +786,47 @@ contains
 
     info = psb_success_
     call wk%free(info)
-!!$    write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
-!!$         & present(desc2),desc%is_valid()
-
-    allocate(wk%wv(nwv),stat=info)    
-    if  (present(desc2).and.(desc%is_valid())) then
-!!$      write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
+    if  (present(desc2)) then
+!!$      write(0,*) 'Check on wrk_alloc 2',&
+!!$           & desc2%get_local_rows(), desc%get_local_rows(),&
+!!$           & desc2%get_local_cols(),desc%get_local_cols()
+!!$      flush(0)
       if (desc2%get_local_cols()>desc%get_local_cols()) then
-        call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
+        call psb_geasb(wk%vx2l,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vy2l,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vtx,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vty,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        allocate(wk%wv(nwv),stat=info)
+        do i=1,nwv
+          call psb_geasb(wk%wv(i),desc2,info,&
+               & scratch=.true.,mold=vmold)
+        end do
       else
-        call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
+!!$        write(0,*) 'Check on wrk_alloc 1.5 ',&
+!!$             & desc%get_local_rows(),&
+!!$             & desc%get_local_cols()
+        call psb_geasb(wk%vx2l,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vy2l,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vtx,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vty,desc,info,&
+             & scratch=.true.,mold=vmold)
+        allocate(wk%wv(nwv),stat=info)
+        do i=1,nwv
+          call psb_geasb(wk%wv(i),desc,info,&
+               & scratch=.true.,mold=vmold)
+        end do
       end if
-    else if (present(desc2)) then
-      call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
-    else if (desc%is_valid()) then
-      call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)      
-    end if
-
-  contains
-    subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold)
-      class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
-      integer(psb_ipk_), intent(in)                     :: nwv
-      type(psb_desc_type), intent(in)                   :: desc
-      class(psb_d_base_vect_type), intent(in), optional  :: vmold
-      
-      integer(psb_ipk_) :: i
-      
+    else
+!!$      write(0,*) 'Check on wrk_alloc 1 ',&
+!!$           & desc%get_local_rows(),&
+!!$           & desc%get_local_cols()
       call psb_geasb(wk%vx2l,desc,info,&
            & scratch=.true.,mold=vmold)
       call psb_geasb(wk%vy2l,desc,info,&
@@ -844,11 +835,12 @@ contains
            & scratch=.true.,mold=vmold)
       call psb_geasb(wk%vty,desc,info,&
            & scratch=.true.,mold=vmold)
+      allocate(wk%wv(nwv),stat=info)
       do i=1,nwv
         call psb_geasb(wk%wv(i),desc,info,&
              & scratch=.true.,mold=vmold)
       end do
-    end subroutine inner_do_wrk_alloc
+    end if
   end subroutine d_wrk_alloc
 
   subroutine d_wrk_free(wk,info)
@@ -1001,25 +993,4 @@ contains
     call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
   end subroutine d_remap_data_clone
 
-  subroutine d_remap_move_alloc(rmp, remap_out, info)
-    use psb_base_mod
-    implicit none
-    ! Arguments
-    class(amg_d_remap_data_type), target, intent(inout) :: rmp
-    class(amg_d_remap_data_type), target, intent(inout) :: remap_out
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-
-    call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
-    if (info == psb_success_) &
-         & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
-    remap_out%idest = rmp%idest
-    call move_alloc(rmp%isrc,remap_out%isrc)
-    call move_alloc(rmp%nrsrc,remap_out%nrsrc)
-    call move_alloc(rmp%naggr,remap_out%naggr)
-  end subroutine d_remap_move_alloc
-  
 end module amg_d_onelev_mod

amgprec/amg_d_parmatch_aggregator_mod.F90

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

amgprec/amg_d_prec_type.f90

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

amgprec/amg_s_base_aggregator_mod.f90

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

amgprec/amg_s_inner_mod.f90

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

amgprec/amg_s_onelev_mod.f90

@@ -155,35 +155,13 @@ module amg_s_onelev_mod
   private :: s_wrk_alloc, s_wrk_free, &
        & s_wrk_clone, s_wrk_move_alloc, s_wrk_cnv, s_wrk_sizeof
 
-  !
-  ! Remap.
-  !  This keeps track of remapping.
-  !  Logic here is as follows:
-  !  1. AC_PRE_REMAP  need to figure out if we
-  !                really need it.
-  !  2. DESC_AC_PRE_REMAP  contains the descriptor before
-  !                remapping. Meaning that it is possible
-  !                to implement the RESTRICTOR operator by
-  !                 a. Doing LINMAP_U2V onto this one
-  !                 b. For each process, send the data to
-  !                    IDEST.
-  !                This assumes that remapping goes by
-  !                a factor of 2.
-  !                For the PROLONGATOR operators, we first
-  !                use DESC_AC, then split and send onto
-  !                the processes in DESC_AC_PRE_REMAP.
-  !
-  ! To be fixed: what happens if NP the starting processes
-  ! is not an even number? Coordinate with _X_remap in PSBLAS
-  ! 
   type amg_s_remap_data_type
     type(psb_sspmat_type)          :: ac_pre_remap
     type(psb_desc_type)            :: desc_ac_pre_remap
     integer(psb_ipk_)              :: idest
     integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
   contains
-    procedure, pass(rmp) :: clone      => s_remap_data_clone
-    procedure, pass(rmp) :: move_alloc => s_remap_move_alloc
+    procedure, pass(rmp) :: clone   => s_remap_data_clone
   end type amg_s_remap_data_type
 
   type amg_s_onelev_type
@@ -229,7 +207,7 @@ module amg_s_onelev_mod
     procedure, pass(lv) :: get_wrksz => s_base_onelev_get_wrksize
     procedure, pass(lv) :: allocate_wrk   => s_base_onelev_allocate_wrk
     procedure, pass(lv) :: free_wrk       => s_base_onelev_free_wrk
-    procedure, nopass   :: stringval  => amg_stringval
+    procedure, nopass   :: stringval => amg_stringval
     procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc
 
 
@@ -641,7 +619,7 @@ contains
     ! Arguments
     class(amg_s_onelev_type), target, intent(inout) :: lv
     class(amg_s_onelev_type), target, intent(inout) :: lvout
-    integer(psb_ipk_), intent(out)                  :: info
+    integer(psb_ipk_), intent(out)                    :: info
 
     info = psb_success_
     if (allocated(lv%sm)) then
@@ -707,7 +685,6 @@ contains
     if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
     if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
     if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
-    if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
     b%base_a    => lv%base_a
     b%base_desc => lv%base_desc
 
@@ -762,7 +739,6 @@ contains
     info = psb_success_
     nwv = lv%get_wrksz()
     if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
-!!$    write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
     if (info == 0) then
       if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
         !
@@ -810,32 +786,47 @@ contains
 
     info = psb_success_
     call wk%free(info)
-!!$    write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
-!!$         & present(desc2),desc%is_valid()
-
-    allocate(wk%wv(nwv),stat=info)    
-    if  (present(desc2).and.(desc%is_valid())) then
-!!$      write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
+    if  (present(desc2)) then
+!!$      write(0,*) 'Check on wrk_alloc 2',&
+!!$           & desc2%get_local_rows(), desc%get_local_rows(),&
+!!$           & desc2%get_local_cols(),desc%get_local_cols()
+!!$      flush(0)
       if (desc2%get_local_cols()>desc%get_local_cols()) then
-        call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
+        call psb_geasb(wk%vx2l,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vy2l,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vtx,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vty,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        allocate(wk%wv(nwv),stat=info)
+        do i=1,nwv
+          call psb_geasb(wk%wv(i),desc2,info,&
+               & scratch=.true.,mold=vmold)
+        end do
       else
-        call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
+!!$        write(0,*) 'Check on wrk_alloc 1.5 ',&
+!!$             & desc%get_local_rows(),&
+!!$             & desc%get_local_cols()
+        call psb_geasb(wk%vx2l,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vy2l,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vtx,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vty,desc,info,&
+             & scratch=.true.,mold=vmold)
+        allocate(wk%wv(nwv),stat=info)
+        do i=1,nwv
+          call psb_geasb(wk%wv(i),desc,info,&
+               & scratch=.true.,mold=vmold)
+        end do
       end if
-    else if (present(desc2)) then
-      call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
-    else if (desc%is_valid()) then
-      call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)      
-    end if
-
-  contains
-    subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold)
-      class(amg_smlprec_wrk_type), target, intent(inout) :: wk
-      integer(psb_ipk_), intent(in)                     :: nwv
-      type(psb_desc_type), intent(in)                   :: desc
-      class(psb_s_base_vect_type), intent(in), optional  :: vmold
-      
-      integer(psb_ipk_) :: i
-      
+    else
+!!$      write(0,*) 'Check on wrk_alloc 1 ',&
+!!$           & desc%get_local_rows(),&
+!!$           & desc%get_local_cols()
       call psb_geasb(wk%vx2l,desc,info,&
            & scratch=.true.,mold=vmold)
       call psb_geasb(wk%vy2l,desc,info,&
@@ -844,11 +835,12 @@ contains
            & scratch=.true.,mold=vmold)
       call psb_geasb(wk%vty,desc,info,&
            & scratch=.true.,mold=vmold)
+      allocate(wk%wv(nwv),stat=info)
       do i=1,nwv
         call psb_geasb(wk%wv(i),desc,info,&
              & scratch=.true.,mold=vmold)
       end do
-    end subroutine inner_do_wrk_alloc
+    end if
   end subroutine s_wrk_alloc
 
   subroutine s_wrk_free(wk,info)
@@ -1001,25 +993,4 @@ contains
     call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
   end subroutine s_remap_data_clone
 
-  subroutine s_remap_move_alloc(rmp, remap_out, info)
-    use psb_base_mod
-    implicit none
-    ! Arguments
-    class(amg_s_remap_data_type), target, intent(inout) :: rmp
-    class(amg_s_remap_data_type), target, intent(inout) :: remap_out
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-
-    call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
-    if (info == psb_success_) &
-         & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
-    remap_out%idest = rmp%idest
-    call move_alloc(rmp%isrc,remap_out%isrc)
-    call move_alloc(rmp%nrsrc,remap_out%nrsrc)
-    call move_alloc(rmp%naggr,remap_out%naggr)
-  end subroutine s_remap_move_alloc
-  
 end module amg_s_onelev_mod

amgprec/amg_s_parmatch_aggregator_mod.F90

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

amgprec/amg_s_prec_type.f90

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

amgprec/amg_z_base_aggregator_mod.f90

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

amgprec/amg_z_inner_mod.f90

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

amgprec/amg_z_onelev_mod.f90

@@ -154,35 +154,13 @@ module amg_z_onelev_mod
   private :: z_wrk_alloc, z_wrk_free, &
        & z_wrk_clone, z_wrk_move_alloc, z_wrk_cnv, z_wrk_sizeof
 
-  !
-  ! Remap.
-  !  This keeps track of remapping.
-  !  Logic here is as follows:
-  !  1. AC_PRE_REMAP  need to figure out if we
-  !                really need it.
-  !  2. DESC_AC_PRE_REMAP  contains the descriptor before
-  !                remapping. Meaning that it is possible
-  !                to implement the RESTRICTOR operator by
-  !                 a. Doing LINMAP_U2V onto this one
-  !                 b. For each process, send the data to
-  !                    IDEST.
-  !                This assumes that remapping goes by
-  !                a factor of 2.
-  !                For the PROLONGATOR operators, we first
-  !                use DESC_AC, then split and send onto
-  !                the processes in DESC_AC_PRE_REMAP.
-  !
-  ! To be fixed: what happens if NP the starting processes
-  ! is not an even number? Coordinate with _X_remap in PSBLAS
-  ! 
   type amg_z_remap_data_type
     type(psb_zspmat_type)          :: ac_pre_remap
     type(psb_desc_type)            :: desc_ac_pre_remap
     integer(psb_ipk_)              :: idest
     integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
   contains
-    procedure, pass(rmp) :: clone      => z_remap_data_clone
-    procedure, pass(rmp) :: move_alloc => z_remap_move_alloc
+    procedure, pass(rmp) :: clone   => z_remap_data_clone
   end type amg_z_remap_data_type
 
   type amg_z_onelev_type
@@ -228,7 +206,7 @@ module amg_z_onelev_mod
     procedure, pass(lv) :: get_wrksz => z_base_onelev_get_wrksize
     procedure, pass(lv) :: allocate_wrk   => z_base_onelev_allocate_wrk
     procedure, pass(lv) :: free_wrk       => z_base_onelev_free_wrk
-    procedure, nopass   :: stringval  => amg_stringval
+    procedure, nopass   :: stringval => amg_stringval
     procedure, pass(lv) :: move_alloc => z_base_onelev_move_alloc
 
 
@@ -640,7 +618,7 @@ contains
     ! Arguments
     class(amg_z_onelev_type), target, intent(inout) :: lv
     class(amg_z_onelev_type), target, intent(inout) :: lvout
-    integer(psb_ipk_), intent(out)                  :: info
+    integer(psb_ipk_), intent(out)                    :: info
 
     info = psb_success_
     if (allocated(lv%sm)) then
@@ -706,7 +684,6 @@ contains
     if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
     if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
     if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
-    if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
     b%base_a    => lv%base_a
     b%base_desc => lv%base_desc
 
@@ -761,7 +738,6 @@ contains
     info = psb_success_
     nwv = lv%get_wrksz()
     if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
-!!$    write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
     if (info == 0) then
       if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
         !
@@ -809,32 +785,47 @@ contains
 
     info = psb_success_
     call wk%free(info)
-!!$    write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
-!!$         & present(desc2),desc%is_valid()
-
-    allocate(wk%wv(nwv),stat=info)    
-    if  (present(desc2).and.(desc%is_valid())) then
-!!$      write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
+    if  (present(desc2)) then
+!!$      write(0,*) 'Check on wrk_alloc 2',&
+!!$           & desc2%get_local_rows(), desc%get_local_rows(),&
+!!$           & desc2%get_local_cols(),desc%get_local_cols()
+!!$      flush(0)
       if (desc2%get_local_cols()>desc%get_local_cols()) then
-        call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
+        call psb_geasb(wk%vx2l,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vy2l,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vtx,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vty,desc2,info,&
+             & scratch=.true.,mold=vmold)
+        allocate(wk%wv(nwv),stat=info)
+        do i=1,nwv
+          call psb_geasb(wk%wv(i),desc2,info,&
+               & scratch=.true.,mold=vmold)
+        end do
       else
-        call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
+!!$        write(0,*) 'Check on wrk_alloc 1.5 ',&
+!!$             & desc%get_local_rows(),&
+!!$             & desc%get_local_cols()
+        call psb_geasb(wk%vx2l,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vy2l,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vtx,desc,info,&
+             & scratch=.true.,mold=vmold)
+        call psb_geasb(wk%vty,desc,info,&
+             & scratch=.true.,mold=vmold)
+        allocate(wk%wv(nwv),stat=info)
+        do i=1,nwv
+          call psb_geasb(wk%wv(i),desc,info,&
+               & scratch=.true.,mold=vmold)
+        end do
       end if
-    else if (present(desc2)) then
-      call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
-    else if (desc%is_valid()) then
-      call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)      
-    end if
-
-  contains
-    subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold)
-      class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
-      integer(psb_ipk_), intent(in)                     :: nwv
-      type(psb_desc_type), intent(in)                   :: desc
-      class(psb_z_base_vect_type), intent(in), optional  :: vmold
-      
-      integer(psb_ipk_) :: i
-      
+    else
+!!$      write(0,*) 'Check on wrk_alloc 1 ',&
+!!$           & desc%get_local_rows(),&
+!!$           & desc%get_local_cols()
       call psb_geasb(wk%vx2l,desc,info,&
            & scratch=.true.,mold=vmold)
       call psb_geasb(wk%vy2l,desc,info,&
@@ -843,11 +834,12 @@ contains
            & scratch=.true.,mold=vmold)
       call psb_geasb(wk%vty,desc,info,&
            & scratch=.true.,mold=vmold)
+      allocate(wk%wv(nwv),stat=info)
       do i=1,nwv
         call psb_geasb(wk%wv(i),desc,info,&
              & scratch=.true.,mold=vmold)
       end do
-    end subroutine inner_do_wrk_alloc
+    end if
   end subroutine z_wrk_alloc
 
   subroutine z_wrk_free(wk,info)
@@ -1000,25 +992,4 @@ contains
     call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
   end subroutine z_remap_data_clone
 
-  subroutine z_remap_move_alloc(rmp, remap_out, info)
-    use psb_base_mod
-    implicit none
-    ! Arguments
-    class(amg_z_remap_data_type), target, intent(inout) :: rmp
-    class(amg_z_remap_data_type), target, intent(inout) :: remap_out
-    integer(psb_ipk_), intent(out)                    :: info
-    !
-    integer(psb_ipk_) :: i
-
-    info = psb_success_
-
-    call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
-    if (info == psb_success_) &
-         & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
-    remap_out%idest = rmp%idest
-    call move_alloc(rmp%isrc,remap_out%isrc)
-    call move_alloc(rmp%nrsrc,remap_out%nrsrc)
-    call move_alloc(rmp%naggr,remap_out%naggr)
-  end subroutine z_remap_move_alloc
-  
 end module amg_z_onelev_mod

amgprec/amg_z_prec_type.f90

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

amgprec/impl/Makefile

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

amgprec/impl/aggregator/amg_c_dec_aggregator_mat_asb.f90

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

amgprec/impl/aggregator/amg_c_dec_aggregator_mat_bld.f90

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

amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90

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

amgprec/impl/aggregator/amg_d_dec_aggregator_mat_asb.f90

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

amgprec/impl/aggregator/amg_d_dec_aggregator_mat_bld.f90

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

amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90

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

amgprec/impl/aggregator/amg_s_dec_aggregator_mat_asb.f90

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

amgprec/impl/aggregator/amg_s_dec_aggregator_mat_bld.f90

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

amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90

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

amgprec/impl/aggregator/amg_z_dec_aggregator_mat_asb.f90

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

amgprec/impl/aggregator/amg_z_dec_aggregator_mat_bld.f90

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

amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90

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

amgprec/impl/amg_c_hierarchy_bld.F90

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

amgprec/impl/amg_c_smoothers_bld.f90

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

amgprec/impl/amg_cfile_prec_descr.f90

@@ -88,6 +88,7 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
   logical             :: is_symgs
   character(len=20), parameter :: name='amg_file_prec_descr'
   integer(psb_ipk_)  :: iout_, root_, verbosity_
+  integer(psb_lpk_)  :: gl_nrows,gl_ncols,gl_nzeros
   character(1024)    :: prefix_
 
   info = psb_success_
@@ -122,6 +123,12 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
     if (root_ == -1) root_ = me
 
     if (verbosity_ >=0) then 
+      gl_nrows = prec%precv(1)%base_a%get_nrows()
+      gl_ncols = prec%precv(1)%base_a%get_ncols()
+      gl_nzeros = prec%precv(1)%base_a%get_nzeros()
+      call psb_sum(ctxt,gl_nrows)
+      call psb_sum(ctxt,gl_ncols)
+      call psb_sum(ctxt,gl_nzeros)
       !
       ! The preconditioner description is printed by processor psb_root_.
       ! This agrees with the fact that all the parameters defining the
@@ -129,7 +136,7 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
       ! ensured by amg_precbld).
       !
       if (me == root_) then
-        nlev = prec%get_nlevs()
+        nlev = size(prec%precv)
         do ilev = 1, nlev 
           if (.not.allocated(prec%precv(ilev)%sm)) then 
             info = 3111
@@ -141,8 +148,11 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
 
         write(iout_,*) 
         write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description'
-        write(iout_,*) 'At level :',1,' we have ',np,' processes'
-
+        write(iout_,*) 
+        write(iout_,*) trim(prefix_),' Base matrix      : ',&
+             & gl_nrows, gl_ncols, gl_nzeros
+        write(iout_,*)
+        
         if (nlev == 1) then
           !
           ! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.

amgprec/impl/amg_cmlprec_aply.f90

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

amgprec/impl/amg_cmlprec_aply_a.f90

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

amgprec/impl/amg_cprecinit.F90

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

amgprec/impl/amg_d_hierarchy_bld.F90

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

amgprec/impl/amg_d_smoothers_bld.f90

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

amgprec/impl/amg_dfile_prec_descr.f90

@@ -88,6 +88,7 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
   logical             :: is_symgs
   character(len=20), parameter :: name='amg_file_prec_descr'
   integer(psb_ipk_)  :: iout_, root_, verbosity_
+  integer(psb_lpk_)  :: gl_nrows,gl_ncols,gl_nzeros
   character(1024)    :: prefix_
 
   info = psb_success_
@@ -122,6 +123,12 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
     if (root_ == -1) root_ = me
 
     if (verbosity_ >=0) then 
+      gl_nrows = prec%precv(1)%base_a%get_nrows()
+      gl_ncols = prec%precv(1)%base_a%get_ncols()
+      gl_nzeros = prec%precv(1)%base_a%get_nzeros()
+      call psb_sum(ctxt,gl_nrows)
+      call psb_sum(ctxt,gl_ncols)
+      call psb_sum(ctxt,gl_nzeros)
       !
       ! The preconditioner description is printed by processor psb_root_.
       ! This agrees with the fact that all the parameters defining the
@@ -129,7 +136,7 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
       ! ensured by amg_precbld).
       !
       if (me == root_) then
-        nlev = prec%get_nlevs()
+        nlev = size(prec%precv)
         do ilev = 1, nlev 
           if (.not.allocated(prec%precv(ilev)%sm)) then 
             info = 3111
@@ -141,8 +148,11 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
 
         write(iout_,*) 
         write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description'
-        write(iout_,*) 'At level :',1,' we have ',np,' processes'
-
+        write(iout_,*) 
+        write(iout_,*) trim(prefix_),' Base matrix      : ',&
+             & gl_nrows, gl_ncols, gl_nzeros
+        write(iout_,*)
+        
         if (nlev == 1) then
           !
           ! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.

amgprec/impl/amg_dmlprec_aply.f90

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

amgprec/impl/amg_dmlprec_aply_a.f90

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

amgprec/impl/amg_dprecinit.F90

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

amgprec/impl/amg_s_hierarchy_bld.F90

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

amgprec/impl/amg_s_smoothers_bld.f90

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

amgprec/impl/amg_sfile_prec_descr.f90

@@ -88,6 +88,7 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
   logical             :: is_symgs
   character(len=20), parameter :: name='amg_file_prec_descr'
   integer(psb_ipk_)  :: iout_, root_, verbosity_
+  integer(psb_lpk_)  :: gl_nrows,gl_ncols,gl_nzeros
   character(1024)    :: prefix_
 
   info = psb_success_
@@ -122,6 +123,12 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
     if (root_ == -1) root_ = me
 
     if (verbosity_ >=0) then 
+      gl_nrows = prec%precv(1)%base_a%get_nrows()
+      gl_ncols = prec%precv(1)%base_a%get_ncols()
+      gl_nzeros = prec%precv(1)%base_a%get_nzeros()
+      call psb_sum(ctxt,gl_nrows)
+      call psb_sum(ctxt,gl_ncols)
+      call psb_sum(ctxt,gl_nzeros)
       !
       ! The preconditioner description is printed by processor psb_root_.
       ! This agrees with the fact that all the parameters defining the
@@ -129,7 +136,7 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
       ! ensured by amg_precbld).
       !
       if (me == root_) then
-        nlev = prec%get_nlevs()
+        nlev = size(prec%precv)
         do ilev = 1, nlev 
           if (.not.allocated(prec%precv(ilev)%sm)) then 
             info = 3111
@@ -141,8 +148,11 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
 
         write(iout_,*) 
         write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description'
-        write(iout_,*) 'At level :',1,' we have ',np,' processes'
-
+        write(iout_,*) 
+        write(iout_,*) trim(prefix_),' Base matrix      : ',&
+             & gl_nrows, gl_ncols, gl_nzeros
+        write(iout_,*)
+        
         if (nlev == 1) then
           !
           ! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.

amgprec/impl/amg_smlprec_aply.f90

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

amgprec/impl/amg_smlprec_aply_a.f90

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

amgprec/impl/amg_sprecinit.F90

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

amgprec/impl/amg_z_hierarchy_bld.F90

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

amgprec/impl/amg_z_smoothers_bld.f90

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

amgprec/impl/amg_zfile_prec_descr.f90

@@ -88,6 +88,7 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
   logical             :: is_symgs
   character(len=20), parameter :: name='amg_file_prec_descr'
   integer(psb_ipk_)  :: iout_, root_, verbosity_
+  integer(psb_lpk_)  :: gl_nrows,gl_ncols,gl_nzeros
   character(1024)    :: prefix_
 
   info = psb_success_
@@ -122,6 +123,12 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
     if (root_ == -1) root_ = me
 
     if (verbosity_ >=0) then 
+      gl_nrows = prec%precv(1)%base_a%get_nrows()
+      gl_ncols = prec%precv(1)%base_a%get_ncols()
+      gl_nzeros = prec%precv(1)%base_a%get_nzeros()
+      call psb_sum(ctxt,gl_nrows)
+      call psb_sum(ctxt,gl_ncols)
+      call psb_sum(ctxt,gl_nzeros)
       !
       ! The preconditioner description is printed by processor psb_root_.
       ! This agrees with the fact that all the parameters defining the
@@ -129,7 +136,7 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
       ! ensured by amg_precbld).
       !
       if (me == root_) then
-        nlev = prec%get_nlevs()
+        nlev = size(prec%precv)
         do ilev = 1, nlev 
           if (.not.allocated(prec%precv(ilev)%sm)) then 
             info = 3111
@@ -141,8 +148,11 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
 
         write(iout_,*) 
         write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description'
-        write(iout_,*) 'At level :',1,' we have ',np,' processes'
-
+        write(iout_,*) 
+        write(iout_,*) trim(prefix_),' Base matrix      : ',&
+             & gl_nrows, gl_ncols, gl_nzeros
+        write(iout_,*)
+        
         if (nlev == 1) then
           !
           ! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.

amgprec/impl/amg_zmlprec_aply.f90

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

amgprec/impl/amg_zmlprec_aply_a.f90

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

amgprec/impl/amg_zprecinit.F90

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

amgprec/impl/level/amg_c_base_onelev_descr.f90

@@ -62,8 +62,6 @@ subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
   integer(psb_ipk_)  :: iout_, verbosity_
   logical      :: coarse
   character(1024)    :: prefix_
-  type(psb_ctxt_type) :: pctxt
-  integer(psb_ipk_)   :: pme, pnp
 
 
   call psb_erractionsave(err_act)
@@ -83,16 +81,12 @@ subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
     verbosity_ = 0
   end if
   if (verbosity_ < 0) goto 9998
-  if (present(prefix)) then
-    prefix_ = prefix
-  else
-    prefix_ = ""
-  end if
-  
-  pctxt = lv%desc_ac%get_ctxt()
-  call psb_info(pctxt,pme,pnp) 
-  write(iout_,*) trim(prefix_)
-  write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
   write(iout_,*) trim(prefix_)
   if (il == ilmin) then 
     call lv%parms%mlcycledsc(iout_,info)

amgprec/impl/level/amg_c_base_onelev_map_prol.F90

@@ -46,15 +46,6 @@ subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
   integer(psb_ipk_), intent(out)       :: info
   complex(psb_spk_), optional          :: work(:)
   type(psb_c_vect_type), optional, target, intent(inout)  :: vtx,vty
-
-  type(psb_c_vect_type), pointer   :: vtx_
-
-!!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-  if (present(vtx)) then
-    vtx_ => vtx
-  else
-    vtx_ => lv%wrk%wv(1)
-  end if
   
 !!$  write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
   if (lv%remap_data%ac_pre_remap%is_asb()) then
@@ -98,16 +89,14 @@ subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
         call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
 !!$        write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
         
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
+        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
 !!$        write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
 !!$        write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
-!!$        call psb_realloc(nrc,rsnd,info)
-!!$        call psb_rcv(ctxt,rsnd(1:nrl),idest)
-!!$        call tv%set_vect(rsnd)
-        call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
-        call tv%set_host()
+        call psb_realloc(nrc,rsnd,info)
+        call psb_rcv(ctxt,rsnd(1:nrl),idest)
+        call tv%set_vect(rsnd)
         call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
-             & work=work,vtx=vtx_,vty=vty)
+             & work=work,vtx=vtx,vty=vty)
       end associate
 !!$      write(0,*) me, ' Prolongator with remap done '
 !!$      flush(0)
@@ -116,7 +105,7 @@ subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
   else
     ! Default transfer
     call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
-         & work=work,vtx=vtx_,vty=vty)
+         & work=work,vtx=vtx,vty=vty)
   end if
   
 end subroutine amg_c_base_onelev_map_prol_v
@@ -136,7 +125,7 @@ subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
     !
     ! Remap has happened, deal with it
     !
-    write(0,*) 'Remap P handling not implemented yet for A'
+    write(0,*) 'Remap handling not implemented yet '
   else
     ! Default transfer
     call lv%linmap%map_V2U(alpha,v,beta,u,info,&

amgprec/impl/level/amg_c_base_onelev_map_rstr.F90

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

amgprec/impl/level/amg_c_base_onelev_mat_asb.f90

@@ -168,7 +168,7 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   if (do_timings) call psb_tic(idx_mapbld)  
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
-  if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
+  if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
        & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
   if (do_timings) call psb_toc(idx_mapbld)  
   if(info /= psb_success_) then

amgprec/impl/level/amg_d_base_onelev_descr.f90

@@ -62,8 +62,6 @@ subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
   integer(psb_ipk_)  :: iout_, verbosity_
   logical      :: coarse
   character(1024)    :: prefix_
-  type(psb_ctxt_type) :: pctxt
-  integer(psb_ipk_)   :: pme, pnp
 
 
   call psb_erractionsave(err_act)
@@ -83,16 +81,12 @@ subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
     verbosity_ = 0
   end if
   if (verbosity_ < 0) goto 9998
-  if (present(prefix)) then
-    prefix_ = prefix
-  else
-    prefix_ = ""
-  end if
-  
-  pctxt = lv%desc_ac%get_ctxt()
-  call psb_info(pctxt,pme,pnp) 
-  write(iout_,*) trim(prefix_)
-  write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
   write(iout_,*) trim(prefix_)
   if (il == ilmin) then 
     call lv%parms%mlcycledsc(iout_,info)

amgprec/impl/level/amg_d_base_onelev_map_prol.F90

@@ -46,15 +46,6 @@ subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
   integer(psb_ipk_), intent(out)       :: info
   real(psb_dpk_), optional          :: work(:)
   type(psb_d_vect_type), optional, target, intent(inout)  :: vtx,vty
-
-  type(psb_d_vect_type), pointer   :: vtx_
-
-!!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-  if (present(vtx)) then
-    vtx_ => vtx
-  else
-    vtx_ => lv%wrk%wv(1)
-  end if
   
 !!$  write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
   if (lv%remap_data%ac_pre_remap%is_asb()) then
@@ -98,16 +89,14 @@ subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
         call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
 !!$        write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
         
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
+        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
 !!$        write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
 !!$        write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
-!!$        call psb_realloc(nrc,rsnd,info)
-!!$        call psb_rcv(ctxt,rsnd(1:nrl),idest)
-!!$        call tv%set_vect(rsnd)
-        call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
-        call tv%set_host()
+        call psb_realloc(nrc,rsnd,info)
+        call psb_rcv(ctxt,rsnd(1:nrl),idest)
+        call tv%set_vect(rsnd)
         call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
-             & work=work,vtx=vtx_,vty=vty)
+             & work=work,vtx=vtx,vty=vty)
       end associate
 !!$      write(0,*) me, ' Prolongator with remap done '
 !!$      flush(0)
@@ -116,7 +105,7 @@ subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
   else
     ! Default transfer
     call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
-         & work=work,vtx=vtx_,vty=vty)
+         & work=work,vtx=vtx,vty=vty)
   end if
   
 end subroutine amg_d_base_onelev_map_prol_v
@@ -136,7 +125,7 @@ subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
     !
     ! Remap has happened, deal with it
     !
-    write(0,*) 'Remap P handling not implemented yet for A'
+    write(0,*) 'Remap handling not implemented yet '
   else
     ! Default transfer
     call lv%linmap%map_V2U(alpha,v,beta,u,info,&

amgprec/impl/level/amg_d_base_onelev_map_rstr.F90

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

amgprec/impl/level/amg_d_base_onelev_mat_asb.f90

@@ -168,7 +168,7 @@ subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   if (do_timings) call psb_tic(idx_mapbld)  
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
-  if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
+  if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
        & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
   if (do_timings) call psb_toc(idx_mapbld)  
   if(info /= psb_success_) then

amgprec/impl/level/amg_s_base_onelev_descr.f90

@@ -62,8 +62,6 @@ subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
   integer(psb_ipk_)  :: iout_, verbosity_
   logical      :: coarse
   character(1024)    :: prefix_
-  type(psb_ctxt_type) :: pctxt
-  integer(psb_ipk_)   :: pme, pnp
 
 
   call psb_erractionsave(err_act)
@@ -83,16 +81,12 @@ subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
     verbosity_ = 0
   end if
   if (verbosity_ < 0) goto 9998
-  if (present(prefix)) then
-    prefix_ = prefix
-  else
-    prefix_ = ""
-  end if
-  
-  pctxt = lv%desc_ac%get_ctxt()
-  call psb_info(pctxt,pme,pnp) 
-  write(iout_,*) trim(prefix_)
-  write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
   write(iout_,*) trim(prefix_)
   if (il == ilmin) then 
     call lv%parms%mlcycledsc(iout_,info)

amgprec/impl/level/amg_s_base_onelev_map_prol.F90

@@ -46,15 +46,6 @@ subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
   integer(psb_ipk_), intent(out)       :: info
   real(psb_spk_), optional          :: work(:)
   type(psb_s_vect_type), optional, target, intent(inout)  :: vtx,vty
-
-  type(psb_s_vect_type), pointer   :: vtx_
-
-!!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-  if (present(vtx)) then
-    vtx_ => vtx
-  else
-    vtx_ => lv%wrk%wv(1)
-  end if
   
 !!$  write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
   if (lv%remap_data%ac_pre_remap%is_asb()) then
@@ -98,16 +89,14 @@ subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
         call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
 !!$        write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
         
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
+        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
 !!$        write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
 !!$        write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
-!!$        call psb_realloc(nrc,rsnd,info)
-!!$        call psb_rcv(ctxt,rsnd(1:nrl),idest)
-!!$        call tv%set_vect(rsnd)
-        call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
-        call tv%set_host()
+        call psb_realloc(nrc,rsnd,info)
+        call psb_rcv(ctxt,rsnd(1:nrl),idest)
+        call tv%set_vect(rsnd)
         call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
-             & work=work,vtx=vtx_,vty=vty)
+             & work=work,vtx=vtx,vty=vty)
       end associate
 !!$      write(0,*) me, ' Prolongator with remap done '
 !!$      flush(0)
@@ -116,7 +105,7 @@ subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
   else
     ! Default transfer
     call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
-         & work=work,vtx=vtx_,vty=vty)
+         & work=work,vtx=vtx,vty=vty)
   end if
   
 end subroutine amg_s_base_onelev_map_prol_v
@@ -136,7 +125,7 @@ subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
     !
     ! Remap has happened, deal with it
     !
-    write(0,*) 'Remap P handling not implemented yet for A'
+    write(0,*) 'Remap handling not implemented yet '
   else
     ! Default transfer
     call lv%linmap%map_V2U(alpha,v,beta,u,info,&

amgprec/impl/level/amg_s_base_onelev_map_rstr.F90

@@ -47,33 +47,25 @@ subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
   integer(psb_ipk_), intent(out)       :: info
   real(psb_spk_), optional          :: work(:)
   type(psb_s_vect_type), optional, target, intent(inout)  :: vtx,vty
-  type(psb_s_vect_type), pointer   :: vty_
-  integer(psb_mpk_) :: me, np
 
 !!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-  if (present(vty)) then
-    vty_ => vty
-  else
-    vty_ => lv%wrk%wv(1)
-  end if
-  
   if (lv%remap_data%ac_pre_remap%is_asb()) then
     !
     ! Remap has happened, deal with it
     !
 !!$    write(0,*) 'Remap handling not implemented yet '
     block
-      type(psb_ctxt_type) :: ctxt, rctxt
+      type(psb_ctxt_type) :: ctxt, nctxt
       integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
-      integer(psb_mpk_) :: rme, rnp
+      integer(psb_mpk_) :: me, np,  rme, rnp
       real(psb_spk_), allocatable :: rsnd(:), rrcv(:)
       type(psb_s_vect_type) :: tv
       
       ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
       call psb_info(ctxt,me,np)
-      rctxt = lv%desc_ac%get_ctxt()
-      call psb_info(rctxt,rme,rnp)
-!!$      write(0,*) 'New context map rstr',rme,rnp,me,np
+      nctxt = lv%desc_ac%get_ctxt()
+      call psb_info(nctxt,rme,rnp)
+!!$      write(0,*) 'New context ',rme,rnp
       idest = lv%remap_data%idest
       associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
 !!$        write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
@@ -81,18 +73,12 @@ subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
         nsrc = size(isrc)
         nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
         call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
-!!$        write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),&
-!!$             & psb_errstatus_fatal()
-!!$        flush(0)
-        call psb_barrier(ctxt)
+        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
+!!$        write(0,*) me,' Size of TV ',tv%get_nrows()
         call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
-             & work=work,vtx=vtx,vty=vty_)
-        call tv%sync()
-        !rsnd = tv%get_vect()
-        !call psb_snd(ctxt,rsnd(1:nrl),idest) 
-!!$        write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal()
-        call psb_snd(ctxt,tv%v%v(1:nrl),idest)
+             & work=work,vtx=vtx,vty=vty)
+        rsnd = tv%get_vect()
+        call psb_snd(ctxt,rsnd(1:nrl),idest)
         if (rme >=0) then
           allocate(rrcv(sum(nrsrc)))
 !!$          write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
@@ -100,28 +86,22 @@ subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
           do i = 1,size(isrc)
             ip = isrc(i)
             nrl = nrsrc(i)
-!!$            write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal()           
+!!$            write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
             call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
             kp = kp + nrl
           end do
           call vect_v%set_vect(rrcv)
         end if
       end associate
-!!$      write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal()     
+!!$      write(0,*) me, ' Restrictor with remap done '
     end block
  
   else
     ! Default transfer
-    block
-      type(psb_ctxt_type) :: ctxt, rctxt
-      ctxt = lv%linmap%p_desc_U%get_ctxt()
-      call psb_info(ctxt,me,np)
-!!$      write(0,*) me,' map_rstr calling U2V: ',me,np
-      call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
-           & work=work,vtx=vtx,vty=vty_)
-    end block
+    call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
+         & work=work,vtx=vtx,vty=vty)
   end if
-!!$  write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal()  
+  
 end subroutine amg_s_base_onelev_map_rstr_v
 
 subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
@@ -139,7 +119,7 @@ subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
     !
     ! Remap has happened, deal with it
     !
-    write(0,*) 'Remap R handling not implemented yet for A'
+    write(0,*) 'Remap handling not implemented yet '
   else
     ! Default transfer
     call lv%linmap%map_U2V(alpha,u,beta,v,info,&

amgprec/impl/level/amg_s_base_onelev_mat_asb.f90

@@ -168,7 +168,7 @@ subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   if (do_timings) call psb_tic(idx_mapbld)  
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
-  if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
+  if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
        & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
   if (do_timings) call psb_toc(idx_mapbld)  
   if(info /= psb_success_) then

amgprec/impl/level/amg_z_base_onelev_descr.f90

@@ -62,8 +62,6 @@ subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
   integer(psb_ipk_)  :: iout_, verbosity_
   logical      :: coarse
   character(1024)    :: prefix_
-  type(psb_ctxt_type) :: pctxt
-  integer(psb_ipk_)   :: pme, pnp
 
 
   call psb_erractionsave(err_act)
@@ -83,16 +81,12 @@ subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
     verbosity_ = 0
   end if
   if (verbosity_ < 0) goto 9998
-  if (present(prefix)) then
-    prefix_ = prefix
-  else
-    prefix_ = ""
-  end if
-  
-  pctxt = lv%desc_ac%get_ctxt()
-  call psb_info(pctxt,pme,pnp) 
-  write(iout_,*) trim(prefix_)
-  write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
+    if (present(prefix)) then
+      prefix_ = prefix
+    else
+      prefix_ = ""
+    end if
+
   write(iout_,*) trim(prefix_)
   if (il == ilmin) then 
     call lv%parms%mlcycledsc(iout_,info)

amgprec/impl/level/amg_z_base_onelev_map_prol.F90

@@ -46,15 +46,6 @@ subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
   integer(psb_ipk_), intent(out)       :: info
   complex(psb_dpk_), optional          :: work(:)
   type(psb_z_vect_type), optional, target, intent(inout)  :: vtx,vty
-
-  type(psb_z_vect_type), pointer   :: vtx_
-
-!!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-  if (present(vtx)) then
-    vtx_ => vtx
-  else
-    vtx_ => lv%wrk%wv(1)
-  end if
   
 !!$  write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
   if (lv%remap_data%ac_pre_remap%is_asb()) then
@@ -98,16 +89,14 @@ subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
         call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
 !!$        write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
         
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
+        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
 !!$        write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
 !!$        write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
-!!$        call psb_realloc(nrc,rsnd,info)
-!!$        call psb_rcv(ctxt,rsnd(1:nrl),idest)
-!!$        call tv%set_vect(rsnd)
-        call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
-        call tv%set_host()
+        call psb_realloc(nrc,rsnd,info)
+        call psb_rcv(ctxt,rsnd(1:nrl),idest)
+        call tv%set_vect(rsnd)
         call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
-             & work=work,vtx=vtx_,vty=vty)
+             & work=work,vtx=vtx,vty=vty)
       end associate
 !!$      write(0,*) me, ' Prolongator with remap done '
 !!$      flush(0)
@@ -116,7 +105,7 @@ subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vt
   else
     ! Default transfer
     call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
-         & work=work,vtx=vtx_,vty=vty)
+         & work=work,vtx=vtx,vty=vty)
   end if
   
 end subroutine amg_z_base_onelev_map_prol_v
@@ -136,7 +125,7 @@ subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
     !
     ! Remap has happened, deal with it
     !
-    write(0,*) 'Remap P handling not implemented yet for A'
+    write(0,*) 'Remap handling not implemented yet '
   else
     ! Default transfer
     call lv%linmap%map_V2U(alpha,v,beta,u,info,&

amgprec/impl/level/amg_z_base_onelev_map_rstr.F90

@@ -47,33 +47,25 @@ subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
   integer(psb_ipk_), intent(out)       :: info
   complex(psb_dpk_), optional          :: work(:)
   type(psb_z_vect_type), optional, target, intent(inout)  :: vtx,vty
-  type(psb_z_vect_type), pointer   :: vty_
-  integer(psb_mpk_) :: me, np
 
 !!$  write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
-  if (present(vty)) then
-    vty_ => vty
-  else
-    vty_ => lv%wrk%wv(1)
-  end if
-  
   if (lv%remap_data%ac_pre_remap%is_asb()) then
     !
     ! Remap has happened, deal with it
     !
 !!$    write(0,*) 'Remap handling not implemented yet '
     block
-      type(psb_ctxt_type) :: ctxt, rctxt
+      type(psb_ctxt_type) :: ctxt, nctxt
       integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
-      integer(psb_mpk_) :: rme, rnp
+      integer(psb_mpk_) :: me, np,  rme, rnp
       complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
       type(psb_z_vect_type) :: tv
       
       ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
       call psb_info(ctxt,me,np)
-      rctxt = lv%desc_ac%get_ctxt()
-      call psb_info(rctxt,rme,rnp)
-!!$      write(0,*) 'New context map rstr',rme,rnp,me,np
+      nctxt = lv%desc_ac%get_ctxt()
+      call psb_info(nctxt,rme,rnp)
+!!$      write(0,*) 'New context ',rme,rnp
       idest = lv%remap_data%idest
       associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
 !!$        write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
@@ -81,18 +73,12 @@ subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
         nsrc = size(isrc)
         nrl  = lv%remap_data%desc_ac_pre_remap%get_local_rows()
         call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
-        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) 
-!!$        write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),&
-!!$             & psb_errstatus_fatal()
-!!$        flush(0)
-        call psb_barrier(ctxt)
+        call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info) 
+!!$        write(0,*) me,' Size of TV ',tv%get_nrows()
         call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
-             & work=work,vtx=vtx,vty=vty_)
-        call tv%sync()
-        !rsnd = tv%get_vect()
-        !call psb_snd(ctxt,rsnd(1:nrl),idest) 
-!!$        write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal()
-        call psb_snd(ctxt,tv%v%v(1:nrl),idest)
+             & work=work,vtx=vtx,vty=vty)
+        rsnd = tv%get_vect()
+        call psb_snd(ctxt,rsnd(1:nrl),idest)
         if (rme >=0) then
           allocate(rrcv(sum(nrsrc)))
 !!$          write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
@@ -100,28 +86,22 @@ subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
           do i = 1,size(isrc)
             ip = isrc(i)
             nrl = nrsrc(i)
-!!$            write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal()           
+!!$            write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
             call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
             kp = kp + nrl
           end do
           call vect_v%set_vect(rrcv)
         end if
       end associate
-!!$      write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal()     
+!!$      write(0,*) me, ' Restrictor with remap done '
     end block
  
   else
     ! Default transfer
-    block
-      type(psb_ctxt_type) :: ctxt, rctxt
-      ctxt = lv%linmap%p_desc_U%get_ctxt()
-      call psb_info(ctxt,me,np)
-!!$      write(0,*) me,' map_rstr calling U2V: ',me,np
-      call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
-           & work=work,vtx=vtx,vty=vty_)
-    end block
+    call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
+         & work=work,vtx=vtx,vty=vty)
   end if
-!!$  write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal()  
+  
 end subroutine amg_z_base_onelev_map_rstr_v
 
 subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
@@ -139,7 +119,7 @@ subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
     !
     ! Remap has happened, deal with it
     !
-    write(0,*) 'Remap R handling not implemented yet for A'
+    write(0,*) 'Remap handling not implemented yet '
   else
     ! Default transfer
     call lv%linmap%map_U2V(alpha,u,beta,v,info,&

amgprec/impl/level/amg_z_base_onelev_mat_asb.f90

@@ -168,7 +168,7 @@ subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
   if (do_timings) call psb_tic(idx_mapbld)  
   if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
   
-  if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
+  if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
        & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
   if (do_timings) call psb_toc(idx_mapbld)  
   if(info /= psb_success_) then

amgprec/impl/smoother/amg_d_poly_smoother_clone_settings.f90

@@ -61,12 +61,7 @@ subroutine amg_d_poly_smoother_clone_settings(sm,smout,info)
     smout%rho_ba    = sm%rho_ba
     smout%rho_estimate  = sm%rho_estimate
     smout%rho_estimate_iterations  = sm%rho_estimate_iterations
-    if (allocated(sm%poly_beta)) then 
-      smout%poly_beta = sm%poly_beta
-    else
-      if (allocated(smout%poly_beta)) deallocate(smout%poly_beta)
-    end if
-
+    smout%poly_beta = sm%poly_beta
     
     if (allocated(smout%sv)) then
       if (.not.same_type_as(sm%sv,smout%sv)) then

amgprec/impl/smoother/amg_s_poly_smoother_clone_settings.f90

@@ -61,12 +61,7 @@ subroutine amg_s_poly_smoother_clone_settings(sm,smout,info)
     smout%rho_ba    = sm%rho_ba
     smout%rho_estimate  = sm%rho_estimate
     smout%rho_estimate_iterations  = sm%rho_estimate_iterations
-    if (allocated(sm%poly_beta)) then 
-      smout%poly_beta = sm%poly_beta
-    else
-      if (allocated(smout%poly_beta)) deallocate(smout%poly_beta)
-    end if
-
+    smout%poly_beta = sm%poly_beta
     
     if (allocated(smout%sv)) then
       if (.not.same_type_as(sm%sv,smout%sv)) then

amgprec/impl/solver/amg_c_diag_solver_bld.f90

@@ -91,6 +91,10 @@ subroutine amg_c_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = cone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)
@@ -172,6 +176,10 @@ subroutine amg_c_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = cone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_c_jac_solver_bld.f90

@@ -100,6 +100,10 @@ subroutine amg_c_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = cone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_c_l1_jac_solver_bld.f90

@@ -103,6 +103,10 @@ subroutine amg_c_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = cone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_d_diag_solver_bld.f90

@@ -91,6 +91,10 @@ subroutine amg_d_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = done/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)
@@ -172,6 +176,10 @@ subroutine amg_d_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = done/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_d_jac_solver_bld.f90

@@ -100,6 +100,10 @@ subroutine amg_d_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = done/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_d_l1_jac_solver_bld.f90

@@ -103,6 +103,10 @@ subroutine amg_d_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = done/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_s_diag_solver_bld.f90

@@ -91,6 +91,10 @@ subroutine amg_s_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = sone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)
@@ -172,6 +176,10 @@ subroutine amg_s_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = sone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_s_jac_solver_bld.f90

@@ -100,6 +100,10 @@ subroutine amg_s_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = sone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_s_l1_jac_solver_bld.f90

@@ -103,6 +103,10 @@ subroutine amg_s_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = sone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_z_diag_solver_bld.f90

@@ -91,6 +91,10 @@ subroutine amg_z_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = zone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)
@@ -172,6 +176,10 @@ subroutine amg_z_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = zone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_z_jac_solver_bld.f90

@@ -100,6 +100,10 @@ subroutine amg_z_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = zone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

amgprec/impl/solver/amg_z_l1_jac_solver_bld.f90

@@ -103,6 +103,10 @@ subroutine amg_z_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
       sv%d(i) = zone/sv%d(i)
     end if
   end do
+  if (allocated(sv%dv)) then
+    call sv%dv%free(info)
+    deallocate(sv%dv)
+  end if
   allocate(sv%dv,stat=info) 
   if (info == psb_success_) then 
     call sv%dv%bld(sv%d)

cbind/amgprec/amg_c_dprec.h

@@ -36,8 +36,9 @@ extern "C" {
   psb_i_t amg_c_dallocate_wrk(amg_c_dprec *ph, const char *chfmt);
 
   psb_i_t amg_c_dkrylov(const char *method, psb_c_dspmat *ah, amg_c_dprec *ph, 
-		  psb_c_dvector *bh, psb_c_dvector *xh,
-		  psb_c_descriptor *cdh, psb_c_SolverOptions *opt);
+			psb_c_dvector *bh, psb_c_dvector *xh,
+			psb_c_descriptor *cdh, psb_c_dvector *s1,
+			psb_c_dvector *s2, psb_c_SolverOptions *opt);
 
 
 #ifdef __cplusplus

cbind/amgprec/amg_c_zprec.h

@@ -40,7 +40,8 @@ extern "C"
 
   psb_i_t amg_c_zkrylov(const char *method, psb_c_zspmat *ah, amg_c_zprec *ph,
                         psb_c_zvector *bh, psb_c_zvector *xh,
-                        psb_c_descriptor *cdh, psb_c_SolverOptions *opt);
+                        psb_c_descriptor *cdh, , psb_c_zvector *s1,
+			psb_c_zvector *s2, psb_c_SolverOptions *opt);
 
 #ifdef __cplusplus
 }

cbind/amgprec/amg_dprec_cbind_mod.F90

@@ -3,6 +3,7 @@ module amg_dprec_cbind_mod
   use iso_c_binding
   use amg_prec_mod
   use psb_base_cbind_mod
+  use psb_dlinsolve_cbind_mod
 
   type, bind(c) :: amg_c_dprec
     type(c_ptr) :: item = c_null_ptr
@@ -172,15 +173,17 @@ contains
   end function amg_c_dprecbld
 
   function  amg_c_dhierarchy_build(ah,cdh,ph) bind(c) result(res)
+    use psb_base_mod
     implicit none
 
     integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
-    integer(psb_ipk_)     :: iret
     type(amg_dprec_type), pointer  :: precp
     type(psb_dspmat_type), pointer :: ap
     type(psb_desc_type), pointer   :: descp
     character(len=80)     :: fptype
+    integer(psb_ipk_)     :: iret, act
+
 
     res = -1
 
@@ -204,11 +207,16 @@ contains
 
     res = AMGC_ERR_FILTER(iret)
     AMGC_ERR_HANDLE(res)
+    if (res /=0) then
+      act = psb_act_abort_
+      call psb_error_handler(act)
+    end if
 
     return
   end function amg_c_dhierarchy_build
 
   function  amg_c_dsmoothers_build(ah,cdh,ph) bind(c) result(res)
+    use psb_base_mod
     implicit none
 
     integer(psb_c_ipk_) :: res
@@ -217,7 +225,7 @@ contains
     type(psb_dspmat_type), pointer :: ap
     type(psb_desc_type), pointer   :: descp
     character(len=80)     :: fptype
-    integer(psb_ipk_)     :: iret
+    integer(psb_ipk_)     :: iret, act
 
     res = -1
 
@@ -241,8 +249,10 @@ contains
 
     res = AMGC_ERR_FILTER(iret)
     AMGC_ERR_HANDLE(res)
-
-    return
+    if (res /=0) then
+      act = psb_act_abort_
+      call psb_error_handler(act)
+    end if
   end function amg_c_dsmoothers_build
 
   function  amg_c_dsmoothers_build_opt(ah,cdh,ph,afmt,cdfmt) bind(c) result(res)
@@ -360,7 +370,7 @@ contains
   end function amg_c_dsmoothers_build_opt
 
   function  amg_c_dkrylov(methd,&
-       & ah,ph,bh,xh,cdh,options) bind(c) result(res)
+       & ah,ph,bh,xh,cdh,s1,s2,options) bind(c) result(res)
     use psb_base_mod
     use psb_prec_mod
     use psb_linsolve_mod
@@ -368,20 +378,21 @@ contains
     use psb_dlinsolve_cbind_mod
     implicit none
     integer(psb_c_ipk_)          :: res
-    type(psb_c_object_type) :: ah,cdh,ph,bh,xh
+    type(psb_c_object_type) :: ah,cdh,ph,bh,xh,s1,s2
     character(c_char)       :: methd(*)
     type(solveroptions)     :: options
 
     res= amg_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)
+         & irst=options%irst, err=options%err, s1=s1,s2=s2)
 
   end function amg_c_dkrylov
 
 
   function  amg_c_dkrylov_opt(methd,&
-       & ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res)
+       & ah,ph,bh,xh,eps,cdh,itmax,iter,err,&
+       & itrace,irst,istop,s1,s2) bind(c) result(res)
     use psb_base_mod
     use psb_prec_mod
     use psb_linsolve_mod
@@ -389,16 +400,17 @@ contains
     use psb_prec_cbind_mod
     implicit none
     integer(psb_c_ipk_)          :: res
-    type(psb_c_object_type) :: ah,cdh,ph,bh,xh
+    type(psb_c_object_type) :: ah,cdh,ph,bh,xh,s1, s2
     integer(psb_c_ipk_), value :: itmax,itrace,irst,istop
     real(c_double), value :: eps
     integer(psb_c_ipk_)        :: iter
     real(c_double)        :: err
     character(c_char)       :: methd(*)
+
     type(psb_desc_type), pointer   :: descp
     type(psb_dspmat_type), pointer :: ap
     type(amg_dprec_type), pointer  :: precp
-    type(psb_d_vect_type), pointer :: xp, bp
+    type(psb_d_vect_type), pointer :: xp, bp, s1p, s2p
 
     integer(psb_ipk_)     :: iret,fitmax,fitrace,first,fistop,fiter
     character(len=20)     :: fmethd
@@ -431,6 +443,16 @@ contains
       return
     end if
 
+    if (c_associated(s1%item)) then
+      call c_f_pointer(s1%item,s1p)
+    else
+      nullify(s1p)
+    end if
+    if (c_associated(s2%item)) then
+      call c_f_pointer(s2%item,s2p)
+    else
+      nullify(s2p)
+    end if
 
     call psb_stringc2f(methd,fmethd)
     feps    = eps
@@ -439,10 +461,28 @@ contains
     first   = irst
     fistop  = istop
 
-    call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
-         & descp, iret,&
-         & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
-         & irst=first, err=ferr)
+    if (associated(s1p).and.associated(s2p)) then
+      call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
+           & descp, iret,&
+           & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
+           & irst=first, err=ferr,s1=s1p,s2=s2p)
+    else if  (associated(s1p)) then
+      call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
+           & descp, iret,&
+           & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
+           & irst=first, err=ferr,s1=s1p)
+    else  if (associated(s2p)) then
+      call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
+           & descp, iret,&
+           & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
+           & irst=first, err=ferr,s2=s2p)
+    else
+      call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
+           & descp, iret,&
+           & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
+           & irst=first, err=ferr)
+    end if
+    
     iter = fiter
     err  = ferr
     res = min(iret,0)
@@ -497,7 +537,7 @@ contains
     res = AMGC_ERR_FILTER(info)
     AMGC_ERR_HANDLE(res)
     return
-end function amg_c_dprecapply
+  end function amg_c_dprecapply
 
   function amg_c_dprecapply_opt(ph,bc,xc,cdh,ctrans) bind(c,name="amg_c_dprecapply_opt") result(res)
     use psb_base_mod
@@ -553,7 +593,7 @@ end function amg_c_dprecapply
     res = AMGC_ERR_FILTER(info)
     AMGC_ERR_HANDLE(res)
     return
-end function amg_c_dprecapply_opt
+  end function amg_c_dprecapply_opt
 
   function  amg_c_dprecfree(ph) bind(c) result(res)
     implicit none

cbind/amgprec/amg_zprec_cbind_mod.F90

@@ -140,11 +140,11 @@ contains
 
     integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
-    integer(psb_ipk_)     :: iret
     type(amg_zprec_type), pointer  :: precp
     type(psb_zspmat_type), pointer :: ap
     type(psb_desc_type), pointer   :: descp
     character(len=80)     :: fptype
+    integer(psb_ipk_)     :: iret
 
     res = -1
 
@@ -173,15 +173,17 @@ contains
   end function amg_c_zprecbld
 
   function  amg_c_zhierarchy_build(ah,cdh,ph) bind(c) result(res)
+    use psb_base_mod
     implicit none
 
     integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
-    integer(psb_ipk_)     :: iret
     type(amg_zprec_type), pointer  :: precp
     type(psb_zspmat_type), pointer :: ap
     type(psb_desc_type), pointer   :: descp
     character(len=80)     :: fptype
+    integer(psb_ipk_)     :: iret, act
+
 
     res = -1
 
@@ -205,20 +207,25 @@ contains
 
     res = AMGC_ERR_FILTER(iret)
     AMGC_ERR_HANDLE(res)
-
+    if (res /=0) then
+      act = psb_act_abort_
+      call psb_error_handler(act)
+    end if
+      
     return
   end function amg_c_zhierarchy_build
 
   function  amg_c_zsmoothers_build(ah,cdh,ph) bind(c) result(res)
+    use psb_base_mod
     implicit none
 
     integer(psb_c_ipk_) :: res
     type(psb_c_object_type)  :: ph,ah,cdh
-    integer(psb_ipk_)     :: iret
     type(amg_zprec_type), pointer  :: precp
     type(psb_zspmat_type), pointer :: ap
     type(psb_desc_type), pointer   :: descp
     character(len=80)     :: fptype
+    integer(psb_ipk_)     :: iret, act
 
     res = -1
 
@@ -242,11 +249,15 @@ contains
 
     res = AMGC_ERR_FILTER(iret)
     AMGC_ERR_HANDLE(res)
+    if (res /=0) then
+      act = psb_act_abort_
+      call psb_error_handler(act)
+    end if
 
     return
   end function amg_c_zsmoothers_build
 
-  function  amg_c_zsmoothers_build_format(ah,cdh,ph,afmt,cdfmt) bind(c) result(res)
+  function  amg_c_zsmoothers_build_opt(ah,cdh,ph,afmt,cdfmt) bind(c) result(res)
 #if defined (PSB_HAVE_CUDA)
     use psb_cuda_mod
 #endif
@@ -352,34 +363,40 @@ contains
     AMGC_ERR_HANDLE(res)
 
     return
-  end function amg_c_zsmoothers_build_format
+  end function amg_c_zsmoothers_build_opt
 
   function  amg_c_zkrylov(methd,&
-       & ah,ph,bh,xh,cdh,options) bind(c) result(res)
+       & ah,ph,bh,xh,cdh,s1,s2,options) bind(c) result(res)
+    use psb_base_mod
+    use psb_prec_mod
     use psb_linsolve_mod
     use psb_prec_cbind_mod
     use psb_zlinsolve_cbind_mod
     implicit none
     integer(psb_c_ipk_)          :: res
-    type(psb_c_object_type) :: ah,cdh,ph,bh,xh
+    type(psb_c_object_type) :: ah,cdh,ph,bh,xh,s1,s2
     character(c_char)       :: methd(*)
     type(solveroptions)     :: options
 
     res= amg_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)
+         & irst=options%irst, err=options%err, s1=s1,s2=s2)
 
   end function amg_c_zkrylov
 
 
   function  amg_c_zkrylov_opt(methd,&
-       & ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res)
+       & ah,ph,bh,xh,eps,cdh,itmax,iter,err,&
+       & itrace,irst,istop,s1,s2) bind(c) result(res)
+    use psb_base_mod
+    use psb_prec_mod
     use psb_linsolve_mod
     use psb_objhandle_mod
+    use psb_prec_cbind_mod
     implicit none
     integer(psb_c_ipk_)          :: res
-    type(psb_c_object_type) :: ah,cdh,ph,bh,xh
+    type(psb_c_object_type) :: ah,cdh,ph,bh,xh,s1, s2
     integer(psb_c_ipk_), value :: itmax,itrace,irst,istop
     real(c_double), value :: eps
     integer(psb_c_ipk_)        :: iter
@@ -388,7 +405,7 @@ contains
     type(psb_desc_type), pointer   :: descp
     type(psb_zspmat_type), pointer :: ap
     type(amg_zprec_type), pointer  :: precp
-    type(psb_z_vect_type), pointer :: xp, bp
+    type(psb_z_vect_type), pointer :: xp, bp, s1p, s2p
 
     integer(psb_ipk_)     :: iret,fitmax,fitrace,first,fistop,fiter
     character(len=20)     :: fmethd
@@ -420,6 +437,16 @@ contains
     else
       return
     end if
+    if (c_associated(s1%item)) then
+      call c_f_pointer(s1%item,s1p)
+    else
+      nullify(s1p)
+    end if
+    if (c_associated(s2%item)) then
+      call c_f_pointer(s2%item,s2p)
+    else
+      nullify(s2p)
+    end if
 
 
     call psb_stringc2f(methd,fmethd)
@@ -429,10 +456,28 @@ contains
     first   = irst
     fistop  = istop
 
-    call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
-         & descp, iret,&
-         & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
-         & irst=first, err=ferr)
+    if (associated(s1p).and.associated(s2p)) then
+      call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
+           & descp, iret,&
+           & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
+           & irst=first, err=ferr,s1=s1p,s2=s2p)
+    else if  (associated(s1p)) then
+      call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
+           & descp, iret,&
+           & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
+           & irst=first, err=ferr,s1=s1p)
+    else  if (associated(s2p)) then
+      call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
+           & descp, iret,&
+           & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
+           & irst=first, err=ferr,s2=s2p)
+    else
+      call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
+           & descp, iret,&
+           & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
+           & irst=first, err=ferr)
+    end if
+
     iter = fiter
     err  = ferr
     res = min(iret,0)

configure

@@ -3451,7 +3451,7 @@ fi
 
 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Loaded $pac_cv_status_file $FC $MPIFC $BLACS_LIBS" >&5
 printf "%s\n" "$as_me: Loaded $pac_cv_status_file $FC $MPIFC $BLACS_LIBS" >&6;}
-am__api_version='1.17'
+am__api_version='1.18'
 
 
 
@@ -3721,10 +3721,14 @@ am_lf='
 '
 case `pwd` in
   *[\\\"\#\$\&\'\`$am_lf]*)
+    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
     as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;;
 esac
 case $srcdir in
   *[\\\"\#\$\&\'\`$am_lf\ \	]*)
+    { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
     as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;;
 esac
 
@@ -4189,9 +4193,133 @@ AMTAR='$${TAR-tar}'
 
 
 # We'll loop over all known methods to create a tar archive until one works.
-_am_tools='gnutar  pax cpio none'
+_am_tools='gnutar plaintar pax cpio none'
 
-am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'
+# The POSIX 1988 'ustar' format is defined with fixed-size fields.
+      # There is notably a 21 bits limit for the UID and the GID.  In fact,
+      # the 'pax' utility can hang on bigger UID/GID (see automake bug#8343
+      # and bug#13588).
+      am_max_uid=2097151 # 2^21 - 1
+      am_max_gid=$am_max_uid
+      # The $UID and $GID variables are not portable, so we need to resort
+      # to the POSIX-mandated id(1) utility.  Errors in the 'id' calls
+      # below are definitely unexpected, so allow the users to see them
+      # (that is, avoid stderr redirection).
+      am_uid=`id -u || echo unknown`
+      am_gid=`id -g || echo unknown`
+      { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether UID '$am_uid' is supported by ustar format" >&5
+printf %s "checking whether UID '$am_uid' is supported by ustar format... " >&6; }
+      if test x$am_uid = xunknown; then
+        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: ancient id detected; assuming current UID is ok, but dist-ustar might not work" >&5
+printf "%s\n" "$as_me: WARNING: ancient id detected; assuming current UID is ok, but dist-ustar might not work" >&2;}
+      elif test $am_uid -le $am_max_uid; then
+        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
+      else
+        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+        _am_tools=none
+      fi
+      { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether GID '$am_gid' is supported by ustar format" >&5
+printf %s "checking whether GID '$am_gid' is supported by ustar format... " >&6; }
+      if test x$gm_gid = xunknown; then
+        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: ancient id detected; assuming current GID is ok, but dist-ustar might not work" >&5
+printf "%s\n" "$as_me: WARNING: ancient id detected; assuming current GID is ok, but dist-ustar might not work" >&2;}
+      elif test $am_gid -le $am_max_gid; then
+        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+printf "%s\n" "yes" >&6; }
+      else
+        { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
+printf "%s\n" "no" >&6; }
+        _am_tools=none
+      fi
+
+  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to create a ustar tar archive" >&5
+printf %s "checking how to create a ustar tar archive... " >&6; }
+
+  # Go ahead even if we have the value already cached.  We do so because we
+  # need to set the values for the 'am__tar' and 'am__untar' variables.
+  _am_tools=${am_cv_prog_tar_ustar-$_am_tools}
+
+  for _am_tool in $_am_tools; do
+    case $_am_tool in
+    gnutar)
+      for _am_tar in tar gnutar gtar; do
+        { echo "$as_me:$LINENO: $_am_tar --version" >&5
+   ($_am_tar --version) >&5 2>&5
+   ac_status=$?
+   echo "$as_me:$LINENO: \$? = $ac_status" >&5
+   (exit $ac_status); } && break
+      done
+      am__tar="$_am_tar --format=ustar -chf - "'"$$tardir"'
+      am__tar_="$_am_tar --format=ustar -chf - "'"$tardir"'
+      am__untar="$_am_tar -xf -"
+      ;;
+    plaintar)
+      # Must skip GNU tar: if it does not support --format= it doesn't create
+      # ustar tarball either.
+      (tar --version) >/dev/null 2>&1 && continue
+      am__tar='tar chf - "$$tardir"'
+      am__tar_='tar chf - "$tardir"'
+      am__untar='tar xf -'
+      ;;
+    pax)
+      am__tar='pax -L -x ustar -w "$$tardir"'
+      am__tar_='pax -L -x ustar -w "$tardir"'
+      am__untar='pax -r'
+      ;;
+    cpio)
+      am__tar='find "$$tardir" -print | cpio -o -H ustar -L'
+      am__tar_='find "$tardir" -print | cpio -o -H ustar -L'
+      am__untar='cpio -i -H ustar -d'
+      ;;
+    none)
+      am__tar=false
+      am__tar_=false
+      am__untar=false
+      ;;
+    esac
+
+    # If the value was cached, stop now.  We just wanted to have am__tar
+    # and am__untar set.
+    test -n "${am_cv_prog_tar_ustar}" && break
+
+    # tar/untar a dummy directory, and stop if the command works.
+    rm -rf conftest.dir
+    mkdir conftest.dir
+    echo GrepMe > conftest.dir/file
+    { echo "$as_me:$LINENO: tardir=conftest.dir && eval $am__tar_ >conftest.tar" >&5
+   (tardir=conftest.dir && eval $am__tar_ >conftest.tar) >&5 2>&5
+   ac_status=$?
+   echo "$as_me:$LINENO: \$? = $ac_status" >&5
+   (exit $ac_status); }
+    rm -rf conftest.dir
+    if test -s conftest.tar; then
+      { echo "$as_me:$LINENO: $am__untar <conftest.tar" >&5
+   ($am__untar <conftest.tar) >&5 2>&5
+   ac_status=$?
+   echo "$as_me:$LINENO: \$? = $ac_status" >&5
+   (exit $ac_status); }
+      { echo "$as_me:$LINENO: cat conftest.dir/file" >&5
+   (cat conftest.dir/file) >&5 2>&5
+   ac_status=$?
+   echo "$as_me:$LINENO: \$? = $ac_status" >&5
+   (exit $ac_status); }
+      grep GrepMe conftest.dir/file >/dev/null 2>&1 && break
+    fi
+  done
+  rm -rf conftest.dir
+
+  if test ${am_cv_prog_tar_ustar+y}
+then :
+  printf %s "(cached) " >&6
+else case e in #(
+  e) am_cv_prog_tar_ustar=$_am_tool ;;
+esac
+fi
+
+  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_tar_ustar" >&5
+printf "%s\n" "$am_cv_prog_tar_ustar" >&6; }
 
 
 
@@ -5210,7 +5338,10 @@ _ACEOF
       break
     fi
   done
-  rm -f core conftest*
+  # aligned with autoconf, so not including core; see bug#72225.
+  rm -f -r a.out a.exe b.out conftest.$ac_ext conftest.$ac_objext \
+    conftest.dSYM conftest1.$ac_ext conftest1.$ac_objext conftest1.dSYM \
+    conftest2.$ac_ext conftest2.$ac_objext conftest2.dSYM
   unset am_i ;;
 esac
 fi
@@ -10651,6 +10782,12 @@ if test "x$amg4psblas_cv_have_mumps" == "xyes" ; then
       { printf "%s\n" "$as_me:${as_lineno-$LINENO}: PSBLAS defines PSB_LPK_ as $pac_cv_psblas_lpk. MUMPS interfacing will fail when called in global mode on very large matrices. " >&5
 printf "%s\n" "$as_me: PSBLAS defines PSB_LPK_ as $pac_cv_psblas_lpk. MUMPS interfacing will fail when called in global mode on very large matrices. " >&6;}
    fi
+   MUMPS_LIBS="-lsmumps -ldmumps -lcmumps -lzmumps -lmumps_common -lpord"
+   if test "x$amg4psblas_cv_mumpslibdir" != "x" ; then
+      { printf "%s\n" "$as_me:${as_lineno-$LINENO}: MUMPSLIBDIR  $amg4psblas_cv_mumpslibdir .." >&5
+printf "%s\n" "$as_me: MUMPSLIBDIR  $amg4psblas_cv_mumpslibdir .." >&6;}
+      MUMPS_LIBS="${MUMPS_LIBS} -L$amg4psblas_cv_mumpslibdir"
+   fi
    if test "x$pac_mumps_fmods_ok" == "xyes" ; then
       FDEFINES="$amg_cv_define_prepend-DAMG_HAVE_MUMPS $amg_cv_define_prepend-DAMG_HAVE_MUMPS_MODULES $MUMPS_MODULES $FDEFINES"
        MUMPS_FLAGS="-DAMG_HAVE_MUMPS $MUMPS_MODULES"

configure.ac

@@ -763,7 +763,11 @@ dnl fi
 if test "x$amg4psblas_cv_have_mumps" == "xyes" ; then
    if test "x$pac_cv_psblas_lpk" == "x8" ; then
       AC_MSG_NOTICE([PSBLAS defines PSB_LPK_ as $pac_cv_psblas_lpk. MUMPS interfacing will fail when called in global mode on very large matrices. ])
-   fi	
+   fi
+   MUMPS_LIBS="-lsmumps -ldmumps -lcmumps -lzmumps -lmumps_common -lpord"
+   if test "x$amg4psblas_cv_mumpslibdir" != "x" ; then
+      MUMPS_LIBS="${MUMPS_LIBS} -L$amg4psblas_cv_mumpslibdir"
+   fi 		   
    if test "x$pac_mumps_fmods_ok" == "xyes" ; then 
       FDEFINES="$amg_cv_define_prepend-DAMG_HAVE_MUMPS $amg_cv_define_prepend-DAMG_HAVE_MUMPS_MODULES $MUMPS_MODULES $FDEFINES"
        MUMPS_FLAGS="-DAMG_HAVE_MUMPS $MUMPS_MODULES"

samples/advanced/pdegen/amg_d_genpde_mod.F90

@@ -176,7 +176,7 @@ contains
     else
       partition_ = 3
     end if
-    deltah   = done/(idim+2)
+    deltah   = done/(idim+1)
     sqdeltah = deltah*deltah
     deltah2  = 2.0_psb_dpk_* deltah
 
@@ -412,9 +412,9 @@ contains
           ! compute gridpoint coordinates
           call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim)
           ! x, y, z coordinates
-          x = (ix-1)*deltah
-          y = (iy-1)*deltah
-          z = (iz-1)*deltah
+          x = (ix)*deltah
+          y = (iy)*deltah
+          z = (iz)*deltah
           zt(k) = f_(x,y,z)
           ! internal point: build discretization
           !
@@ -643,7 +643,7 @@ contains
       f_ => d_null_func_2d
     end if
 
-    deltah   = done/(idim+2)
+    deltah   = done/(idim+1)
     sqdeltah = deltah*deltah
     deltah2  = 2.0_psb_dpk_* deltah
 
@@ -875,8 +875,8 @@ contains
           ! compute gridpoint coordinates
           call idx2ijk(ix,iy,glob_row,idim,idim)
           ! x, y coordinates
-          x = (ix-1)*deltah
-          y = (iy-1)*deltah
+          x = (ix)*deltah
+          y = (iy)*deltah
 
           zt(k) = f_(x,y)
           ! internal point: build discretization

samples/advanced/pdegen/amg_s_genpde_mod.F90

@@ -176,7 +176,7 @@ contains
     else
       partition_ = 3
     end if
-    deltah   = sone/(idim+2)
+    deltah   = sone/(idim+1)
     sqdeltah = deltah*deltah
     deltah2  = 2.0_psb_spk_* deltah
 
@@ -412,9 +412,9 @@ contains
           ! compute gridpoint coordinates
           call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim)
           ! x, y, z coordinates
-          x = (ix-1)*deltah
-          y = (iy-1)*deltah
-          z = (iz-1)*deltah
+          x = (ix)*deltah
+          y = (iy)*deltah
+          z = (iz)*deltah
           zt(k) = f_(x,y,z)
           ! internal point: build discretization
           !
@@ -643,7 +643,7 @@ contains
       f_ => s_null_func_2d
     end if
 
-    deltah   = sone/(idim+2)
+    deltah   = sone/(idim+1)
     sqdeltah = deltah*deltah
     deltah2  = 2.0_psb_spk_* deltah
 
@@ -875,8 +875,8 @@ contains
           ! compute gridpoint coordinates
           call idx2ijk(ix,iy,glob_row,idim,idim)
           ! x, y coordinates
-          x = (ix-1)*deltah
-          y = (iy-1)*deltah
+          x = (ix)*deltah
+          y = (iy)*deltah
 
           zt(k) = f_(x,y)
           ! internal point: build discretization

samples/advanced/remap/Makefile

@@ -1,66 +0,0 @@
-AMGDIR=../../..
-AMGINCDIR=$(AMGDIR)/include
-include $(AMGINCDIR)/Make.inc.amg4psblas
-AMGMODDIR=$(AMGDIR)/modules
-AMGLIBDIR=$(AMGDIR)/lib
-AMG_LIBS=-L$(AMGLIBDIR) -lpsb_linsolve -lamg_prec -lpsb_prec 
-FINCLUDES=$(FMFLAG). $(FMFLAG)$(AMGMODDIR) $(FMFLAG)$(AMGINCDIR) $(PSBLAS_INCLUDES) $(FIFLAG).
-
-LINKOPT=
-EXEDIR=./runs
-DGEN2D=amg_d_pde2d_poisson_mod.o amg_d_pde2d_exp_mod.o \
-  amg_d_pde2d_gauss_mod.o amg_d_pde2d_box_mod.o
-DGEN3D=amg_d_pde3d_poisson_mod.o amg_d_pde3d_exp_mod.o \
-  amg_d_pde3d_gauss_mod.o amg_d_pde3d_box_mod.o 	
-SGEN2D=amg_s_pde2d_poisson_mod.o amg_s_pde2d_exp_mod.o \
-  amg_s_pde2d_gauss_mod.o amg_s_pde2d_box_mod.o
-SGEN3D=amg_s_pde3d_poisson_mod.o amg_s_pde3d_exp_mod.o \
-  amg_s_pde3d_gauss_mod.o amg_s_pde3d_box_mod.o 	
-
-all: amg_s_pde3d amg_d_pde3d amg_s_pde2d amg_d_pde2d
-
-amg_d_pde3d: amg_d_pde3d.o amg_d_genpde_mod.o $(DGEN3D) data_input.o
-	$(FLINK) $(LINKOPT) amg_d_pde3d.o  amg_d_genpde_mod.o $(DGEN3D) data_input.o \
-         -o amg_d_pde3d $(AMG_LIBS) $(PSBLAS_LIBS) $(AMG_LDLIBS) $(LDLIBS)
-	/bin/mv amg_d_pde3d $(EXEDIR)
-
-amg_s_pde3d: amg_s_pde3d.o amg_s_genpde_mod.o $(SGEN3D) data_input.o
-	$(FLINK) $(LINKOPT) amg_s_pde3d.o  amg_s_genpde_mod.o  $(SGEN3D) data_input.o \
-         -o amg_s_pde3d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS)
-	/bin/mv amg_s_pde3d $(EXEDIR)
-
-amg_d_pde2d: amg_d_pde2d.o amg_d_genpde_mod.o  $(DGEN2D) data_input.o
-	$(FLINK) $(LINKOPT) amg_d_pde2d.o amg_d_genpde_mod.o $(DGEN2D) data_input.o \
-         -o amg_d_pde2d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS)
-	/bin/mv amg_d_pde2d $(EXEDIR)
-
-amg_s_pde2d: amg_s_pde2d.o amg_s_genpde_mod.o $(SGEN2D) data_input.o
-	$(FLINK) $(LINKOPT) amg_s_pde2d.o amg_s_genpde_mod.o $(SGEN2D) data_input.o \
-          -o amg_s_pde2d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS)
-	/bin/mv amg_s_pde2d $(EXEDIR)
-
-
-amg_d_pde3d.o amg_s_pde3d.o amg_d_pde2d.o amg_s_pde2d.o: data_input.o
-
-amg_d_pde3d.o: amg_d_genpde_mod.o $(DGEN3D)
-amg_s_pde3d.o: amg_s_genpde_mod.o $(SGEN3D) 
-amg_d_pde2d.o: amg_d_genpde_mod.o $(DGEN2D)
-amg_s_pde2d.o: amg_s_genpde_mod.o $(SGEN2D)
-
-amg_d_genpde_mod.o: $(DGEN3D)
-amg_s_genpde_mod.o: $(SGEN3D)
-amg_d_genpde_mod.o: $(DGEN2D)
-amg_s_genpde_mod.o: $(SGEN2D)
-
-check: all
-	cd runs && ./amg_d_pde2d <amg_pde2d.inp && ./amg_s_pde2d<amg_pde2d.inp
-
-
-clean:
-	/bin/rm -f data_input.o *.o *$(.mod)\
-        $(EXEDIR)/amg_d_pde3d  $(EXEDIR)/amg_s_pde3d $(EXEDIR)/amg_d_pde2d  $(EXEDIR)/amg_s_pde2d
-
-verycleanlib:
-	(cd ../..; make veryclean)
-lib:
-	(cd ../../; make library)

samples/advanced/remap/amg_d_pde2d.F90

@@ -1,843 +0,0 @@
-!
-!
-!                             AMG4PSBLAS version 1.0
-!    Algebraic Multigrid Package
-!               based on PSBLAS (Parallel Sparse BLAS version 3.7)
-!
-!    (C) Copyright 2021
-!
-!        Salvatore Filippone
-!        Pasqua D'Ambra
-!        Fabio Durastante
-!
-!    Redistribution and use in source and binary forms, with or without
-!    modification, are permitted provided that the following conditions
-!    are met:
-!      1. Redistributions of source code must retain the above copyright
-!         notice, this list of conditions and the following disclaimer.
-!      2. Redistributions in binary form must reproduce the above copyright
-!         notice, this list of conditions, and the following disclaimer in the
-!         documentation and/or other materials provided with the distribution.
-!      3. The name of the AMG4PSBLAS group or the names of its contributors may
-!         not be used to endorse or promote products derived from this
-!         software without specific prior written permission.
-!
-!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
-!    BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-!    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-!    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-!    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-!    CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-!    ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-!    POSSIBILITY OF SUCH DAMAGE.
-!
-!
-! File: amg_d_pde2d.f90
-!
-! Program: amg_d_pde2d
-! This sample program solves a linear system obtained by discretizing a
-! PDE with Dirichlet BCs.
-!
-!
-! The PDE is a general second order equation in 2d
-!
-!   a1 dd(u)  a2 dd(u)   b1 d(u)   b2 d(u)
-! -   ------ -  ------   -----  +  ------  + c u = f
-!      dxdx     dydy        dx       dy
-!
-! with Dirichlet boundary conditions
-!   u = g
-!
-!  on the unit square  0<=x,y<=1.
-!
-!
-! Note that if b1=b2=c=0., the PDE is the  Laplace equation.
-!
-! There are three choices available for data distribution:
-! 1. A simple BLOCK distribution
-! 2. A ditribution based on arbitrary assignment of indices to processes,
-!    typically from a graph partitioner
-! 3. A 2D distribution in which the unit square is partitioned
-!    into rectangles, each one assigned to a process.
-!
-program amg_d_pde2d
-  use psb_base_mod
-  use amg_prec_mod
-  use psb_linsolve_mod
-  use psb_util_mod
-  use data_input
-  use amg_d_pde2d_poisson_mod
-  use amg_d_pde2d_exp_mod
-  use amg_d_pde2d_box_mod
-  use amg_d_pde2d_gauss_mod
-  use amg_d_genpde_mod
-#if defined(PSB_OPENMP)
-  use omp_lib
-#endif
-  implicit none
-
-  ! input parameters
-  character(len=20) :: kmethd, ptype
-  character(len=5)  :: afmt
-  character(len=32)  :: pdecoeff
-  integer(psb_ipk_) :: idim
-  integer(psb_epk_) :: system_size
-
-  ! miscellaneous
-  real(psb_dpk_) :: t1, t2, tprec, thier, tslv, tsmth, tpgen
-
-  ! sparse matrix and preconditioner
-  type(psb_dspmat_type) :: a
-  type(amg_dprec_type)  :: prec
-  ! descriptor
-  type(psb_desc_type)   :: desc_a
-  ! dense vectors
-  type(psb_d_vect_type) :: x,b,r
-  ! parallel environment
-  type(psb_ctxt_type) :: ctxt
-  integer(psb_ipk_)   :: iam, np, nth
-
-  ! solver parameters
-  integer(psb_ipk_)        :: iter, itmax,itrace, istopc, irst, nlv
-  integer(psb_epk_) :: amatsize, precsize, descsize, vecsize
-  real(psb_dpk_)   :: err, resmx, resmxp
-
-  !  Solver data
-  type solverdata
-    character(len=40)  :: kmethd      ! Iterative solver
-    integer(psb_ipk_)  :: istopc      ! stopping criterion
-    integer(psb_ipk_)  :: itmax       ! maximum number of iterations
-    integer(psb_ipk_)  :: itrace      ! tracing
-    integer(psb_ipk_)  :: irst        ! restart
-    real(psb_dpk_)     :: eps         ! stopping tolerance
-  end type solverdata
-  type(solverdata)       :: s_choice
-
-  ! preconditioner data
-  type precdata
-
-    ! preconditioner type
-    character(len=40)  :: descr       ! verbose description of the prec
-    character(len=10)  :: ptype       ! preconditioner type
-
-    integer(psb_ipk_)  :: outer_sweeps ! number of outer sweeps: sweeps for 1-level,
-    ! AMG cycles for ML
-    ! general AMG data
-    character(len=32)  :: mlcycle      ! AMG cycle type
-    integer(psb_ipk_)  :: maxlevs      ! maximum number of levels in AMG preconditioner
-
-    ! AMG aggregation
-    character(len=32)  :: aggr_prol    ! aggregation type: SMOOTHED, NONSMOOTHED
-    character(len=32)  :: par_aggr_alg ! parallel aggregation algorithm: DEC, SYMDEC
-    character(len=32)  :: aggr_type    ! Type of aggregation SOC1, SOC2, MATCHBOXP
-    integer(psb_ipk_)  :: aggr_size    ! Requested size of the aggregates for MATCHBOXP
-    character(len=32)  :: aggr_ord     ! ordering for aggregation: NATURAL, DEGREE
-    character(len=32)  :: aggr_filter  ! filtering: FILTER, NO_FILTER
-    real(psb_dpk_)      :: mncrratio    ! minimum aggregation ratio
-    real(psb_dpk_), allocatable :: athresv(:) ! smoothed aggregation threshold vector
-    integer(psb_ipk_)  :: thrvsz       ! size of threshold vector
-    real(psb_dpk_)      :: athres       ! smoothed aggregation threshold
-    integer(psb_ipk_)  :: csizepp      ! minimum size of coarsest matrix per process
-
-    ! AMG smoother or pre-smoother; also 1-lev preconditioner
-    character(len=32)  :: smther       ! (pre-)smoother type: BJAC, AS
-    integer(psb_ipk_)  :: jsweeps      ! (pre-)smoother / 1-lev prec. sweeps
-    integer(psb_ipk_)  :: degree       ! degree for polynomial smoother
-    character(len=32)  :: pvariant     ! polynomial  variant
-    character(len=32)  :: prhovariant  ! how to estimate rho(M^{-1}A)
-    real(psb_dpk_)     :: prhovalue    ! if previous is set value, we set it from this one
-    integer(psb_ipk_)  :: novr         ! number of overlap layers
-    character(len=32)  :: restr        ! restriction over application of AS
-    character(len=32)  :: prol         ! prolongation over application of AS
-    character(len=32)  :: solve        ! local subsolver type: ILU, MILU, ILUT,
-                                       ! UMF, MUMPS, SLU, FWGS, BWGS, JAC
-    integer(psb_ipk_)  :: ssweeps      ! inner solver sweeps
-    character(len=32)  :: variant      ! AINV variant: LLK, etc
-    integer(psb_ipk_)  :: fill         ! fill-in for incomplete LU factorization
-    integer(psb_ipk_)  :: invfill      ! Inverse fill-in for INVK
-    real(psb_dpk_)      :: thr          ! threshold for ILUT factorization
-
-    ! AMG post-smoother; ignored by 1-lev preconditioner
-    character(len=32)  :: smther2      ! post-smoother type: BJAC, AS
-    integer(psb_ipk_)  :: jsweeps2     ! post-smoother sweeps
-    integer(psb_ipk_)  :: degree2      ! degree for polynomial smoother
-    character(len=32)  :: pvariant2    ! polynomial  variant
-    character(len=32)  :: prhovariant2 ! how to estimate rho(M^{-1}A)
-    real(psb_dpk_)     :: prhovalue2   ! if previous is set value, we set it from this one
-    integer(psb_ipk_)  :: novr2        ! number of overlap layers
-    character(len=32)  :: restr2       ! restriction  over application of AS
-    character(len=32)  :: prol2        ! prolongation over application of AS
-    character(len=32)  :: solve2       ! local subsolver type: ILU, MILU, ILUT,
-                                       ! UMF, MUMPS, SLU, FWGS, BWGS, JAC
-    integer(psb_ipk_)  :: ssweeps2     ! inner solver sweeps
-    character(len=32)  :: variant2     ! AINV variant: LLK, etc
-    integer(psb_ipk_)  :: fill2        ! fill-in for incomplete LU factorization
-    integer(psb_ipk_)  :: invfill2     ! Inverse fill-in for INVK
-    real(psb_dpk_)      :: thr2         ! threshold for ILUT factorization
-
-    ! coarsest-level solver
-    character(len=32)  :: cmat         ! coarsest matrix layout: REPL, DIST
-    character(len=32)  :: csolve       ! coarsest-lev solver: BJAC, SLUDIST (distr.
-                                       ! mat.); UMF, MUMPS, SLU, ILU, ILUT, MILU
-                                       ! (repl. mat.)
-    character(len=32)  :: csbsolve     ! coarsest-lev local subsolver: ILU, ILUT,
-                                       ! MILU, UMF, MUMPS, SLU
-    integer(psb_ipk_)  :: cfill        ! fill-in for incomplete LU factorization
-    real(psb_dpk_)     :: cthres        ! threshold for ILUT factorization
-    integer(psb_ipk_)  :: cjswp        ! sweeps for GS or JAC coarsest-lev subsolver
-    ! settings for the Krylov method
-    character(len=16)  :: krm_method  ! Krylov method for coarsest level
-    character(len=16)  :: krm_prec    ! Preconditioner for coarsest level
-    character(len=16)  :: krm_subsolve ! Subsolver for coarsest level
-    character(len=16)  :: krm_global  ! Is the solver global or local? TRUE or FALSE
-    real(psb_dpk_)      :: krm_eps     ! Stopping tolerance
-    integer(psb_ipk_)  :: krm_irst    ! Restart for Krylov method 
-    integer(psb_ipk_)  :: krm_istop   ! Stopping criterion
-    integer(psb_ipk_)  :: krm_itmax   ! Maximum number of iterations
-    integer(psb_ipk_)  :: krm_itrace  ! Trace of the lower Krylov iterations
-    integer(psb_ipk_)  :: krm_fillin  ! Fill-in for incomplete LU factorization
-
-    ! Dump data
-    logical            :: dump = .false.
-    integer(psb_ipk_)  :: dlmin       ! Minimum level to dump 
-    integer(psb_ipk_)  :: dlmax       ! Maximum level to dump
-    logical            :: dump_ac         = .false.
-    logical            :: dump_rp         = .false.
-    logical            :: dump_tprol      = .false.
-    logical            :: dump_smoother   = .false.
-    logical            :: dump_solver     = .false.
-    logical            :: dump_global_num = .false.
-
-  end type precdata
-  type(precdata)       :: p_choice
-
-  ! other variables
-  integer(psb_ipk_)  :: info, i, k
-  character(len=20)  :: name,ch_err
-
-  info=psb_success_
-
-
-  call psb_init(ctxt)
-  call psb_info(ctxt,iam,np)
-#if defined(PSB_OPENMP)
-  !$OMP parallel shared(nth)
-  !$OMP master
-  nth = omp_get_num_threads()
-  !$OMP end master
-  !$OMP end parallel
-#else
-  nth = 1
-#endif
-
-  if (iam < 0) then
-    ! This should not happen, but just in case
-    call psb_exit(ctxt)
-    stop
-  endif
-  if(psb_get_errstatus() /= 0) goto 9999
-  name='amg_d_pde2d'
-  call psb_set_errverbosity(itwo)
-  !
-  ! Hello world
-  !
-  if (iam == psb_root_) then
-    write(*,*) 'Welcome to AMG4PSBLAS version: ',amg_version_string_
-    write(*,*) 'This is the ',trim(name),' sample program'
-  end if
-
-  !
-  !  get parameters
-  !
-  call get_parms(ctxt,afmt,idim,s_choice,p_choice,pdecoeff)
-
-  !
-  !  allocate and fill in the coefficient matrix, rhs and initial guess
-  !
-  call psb_barrier(ctxt)
-  t1 = psb_wtime()
-  select case(psb_toupper(trim(pdecoeff)))
-  case("POISSON")
-    call amg_gen_pde2d(ctxt,idim,a,b,x,desc_a,afmt,&
-         & a1_poisson,a2_poisson,&
-         & b1_poisson,b2_poisson,c_poisson,g_poisson,info)
-  case("EXP")
-    call amg_gen_pde2d(ctxt,idim,a,b,x,desc_a,afmt,&
-         & a1_exp,a2_exp,&
-         & b1_exp,b2_exp,c_exp,g_exp,info)
-  case("BOX")
-    call amg_gen_pde2d(ctxt,idim,a,b,x,desc_a,afmt,&
-         & a1_box,a2_box,&
-         & b1_box,b2_box,c_box,g_box,info)
-  case("GAUSS")
-    call amg_gen_pde2d(ctxt,idim,a,b,x,desc_a,afmt,&
-         & a1_gauss,a2_gauss,&
-         & b1_gauss,b2_gauss,c_gauss,g_gauss,info)
-  case default
-    info=psb_err_from_subroutine_
-    ch_err='amg_gen_pdecoeff'
-    call psb_errpush(info,name,a_err=ch_err)
-    goto 9999
-  end select
-  call psb_barrier(ctxt)
-  tpgen = psb_wtime() - t1
-  if(info /= psb_success_) then
-    info=psb_err_from_subroutine_
-    ch_err='amg_gen_pde2d'
-    call psb_errpush(info,name,a_err=ch_err)
-    goto 9999
-  end if
-
-  if (iam == psb_root_) &
-       & write(psb_out_unit,'("PDE Coefficients             : ",a)')pdecoeff
-  if (iam == psb_root_) &
-       & write(psb_out_unit,'("Overall matrix creation time : ",es12.5)')tpgen
-  if (iam == psb_root_) &
-       & write(psb_out_unit,'(" ")')
-  !
-  ! initialize the preconditioner
-  !
-  call prec%init(ctxt,p_choice%ptype,info)
-  select case(trim(psb_toupper(p_choice%ptype)))
-  case ('NONE','NOPREC')
-    ! Do nothing, keep defaults
-
-  case ('JACOBI','L1-JACOBI','GS','FWGS','FBGS')
-    ! 1-level sweeps from "outer_sweeps"
-    call prec%set('smoother_sweeps', p_choice%jsweeps, info)
-
-  case ('BJAC','POLY')
-    call prec%set('smoother_sweeps', p_choice%jsweeps, info)
-    call prec%set('sub_solve',       p_choice%solve,   info)
-    call prec%set('solver_sweeps',   p_choice%ssweeps,   info)
-    call prec%set('poly_degree',     p_choice%degree,    info)
-    call prec%set('poly_variant',    p_choice%pvariant,  info)
-    if (psb_toupper(p_choice%solve)=='MUMPS') &
-         & call prec%set('mumps_loc_glob','local_solver',info)
-    call prec%set('sub_fillin',      p_choice%fill,    info)
-    call prec%set('sub_iluthrs',     p_choice%thr,     info)
-
-  case('AS')
-    call prec%set('smoother_sweeps', p_choice%jsweeps, info)
-    call prec%set('sub_ovr',         p_choice%novr,    info)
-    call prec%set('sub_restr',       p_choice%restr,   info)
-    call prec%set('sub_prol',        p_choice%prol,    info)
-    call prec%set('sub_solve',       p_choice%solve,   info)
-    call prec%set('solver_sweeps',   p_choice%ssweeps,   info)
-    if (psb_toupper(p_choice%solve)=='MUMPS') &
-         & call prec%set('mumps_loc_glob','local_solver',info)
-    call prec%set('sub_fillin',      p_choice%fill,    info)
-    call prec%set('sub_iluthrs',     p_choice%thr,     info)
-
-  case ('ML')
-    ! multilevel preconditioner
-
-    call prec%set('ml_cycle',        p_choice%mlcycle,    info)
-    call prec%set('outer_sweeps',    p_choice%outer_sweeps,info)
-    if (p_choice%csizepp>0)&
-         & call prec%set('min_coarse_size_per_process', p_choice%csizepp,    info)
-    if (p_choice%mncrratio>1)&
-         & call prec%set('min_cr_ratio',   p_choice%mncrratio, info)
-    if (p_choice%maxlevs>0)&
-         & call prec%set('max_levs',    p_choice%maxlevs,    info)
-    if (p_choice%athres >= dzero) &
-         & call prec%set('aggr_thresh',     p_choice%athres,  info)
-    if (p_choice%thrvsz>0) then
-      do k=1,min(p_choice%thrvsz,size(prec%precv)-1)
-        call prec%set('aggr_thresh',     p_choice%athresv(k),  info,ilev=(k+1))
-      end do
-    end if
-
-    call prec%set('aggr_prol',       p_choice%aggr_prol,   info)
-    call prec%set('par_aggr_alg',    p_choice%par_aggr_alg,   info)
-    call prec%set('aggr_type',       p_choice%aggr_type, info)
-    call prec%set('aggr_size',       p_choice%aggr_size, info)
-
-    call prec%set('aggr_ord',        p_choice%aggr_ord,   info)
-    call prec%set('aggr_filter',     p_choice%aggr_filter,info)
-
-
-    call prec%set('smoother_type',   p_choice%smther,     info)
-    call prec%set('smoother_sweeps', p_choice%jsweeps,    info)
-    call prec%set('poly_degree',     p_choice%degree,    info)
-    call prec%set('poly_variant',    p_choice%pvariant,  info)
-    if (p_choice%prhovalue > dzero ) then
-            call prec%set('poly_rho_ba', p_choice%prhovalue, info)
-    else
-            call prec%set('poly_rho_estimate', p_choice%prhovariant, info)
-    end if
-
-    select case (psb_toupper(p_choice%smther))
-    case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS')
-      ! do nothing
-    case default
-      call prec%set('sub_ovr',         p_choice%novr,       info)
-      call prec%set('sub_restr',       p_choice%restr,      info)
-      call prec%set('sub_prol',        p_choice%prol,       info)
-      select case(trim(psb_toupper(p_choice%solve)))
-      case('INVK')
-        call prec%set('sub_solve',       p_choice%solve,   info)
-      case('INVT')
-        call prec%set('sub_solve',       p_choice%solve,   info)
-      case('AINV')
-        call prec%set('sub_solve',       p_choice%solve,   info)
-        call prec%set('ainv_alg', p_choice%variant,   info)
-      case default
-        call prec%set('sub_solve',       p_choice%solve,   info)
-        if (psb_toupper(p_choice%solve)=='MUMPS') &
-             & call prec%set('mumps_loc_glob','local_solver',info)
-      end select
-      call prec%set('solver_sweeps',   p_choice%ssweeps,   info)
-      call prec%set('sub_fillin',      p_choice%fill,       info)
-      call prec%set('inv_fillin',      p_choice%invfill,    info)
-      call prec%set('sub_iluthrs',     p_choice%thr,        info)
-    end select
-
-    if (psb_toupper(p_choice%smther2) /= 'NONE') then
-      call prec%set('smoother_type',   p_choice%smther2,   info,pos='post')
-      call prec%set('smoother_sweeps', p_choice%jsweeps2,  info,pos='post')
-      call prec%set('poly_degree',     p_choice%degree2,   info,pos='post')
-      call prec%set('poly_variant',    p_choice%pvariant2, info,pos='post')
-      if (p_choice%prhovalue > dzero ) then
-         call prec%set('poly_rho_ba', p_choice%prhovalue2, info,pos='post')
-      else
-         call prec%set('poly_rho_estimate', p_choice%prhovariant2, info,pos='post')
-      end if
-
-      select case (psb_toupper(p_choice%smther2))
-      case ('GS','BWGS','FBGS','JACOBI','L1-JACOBI','L1-FBGS')
-        ! do nothing
-      case default
-        call prec%set('sub_ovr',         p_choice%novr2,     info,pos='post')
-        call prec%set('sub_restr',       p_choice%restr2,    info,pos='post')
-        call prec%set('sub_prol',        p_choice%prol2,     info,pos='post')
-        select case(trim(psb_toupper(p_choice%solve2)))
-        case('INVK')
-          call prec%set('sub_solve',       p_choice%solve2,   info)
-        case('INVT')
-          call prec%set('sub_solve',       p_choice%solve2,   info)
-        case('AINV')
-          call prec%set('sub_solve',       p_choice%solve2,   info)
-          call prec%set('ainv_alg', p_choice%variant2,   info)
-        case default
-          call prec%set('sub_solve',       p_choice%solve2,   info, pos='post')
-          if (psb_toupper(p_choice%solve2)=='MUMPS') &
-               & call prec%set('mumps_loc_glob','local_solver',info)
-        end select
-        call prec%set('solver_sweeps',   p_choice%ssweeps2,   info,pos='post')
-        call prec%set('sub_fillin',      p_choice%fill2,     info,pos='post')
-        call prec%set('inv_fillin',      p_choice%invfill2,  info,pos='post')
-        call prec%set('sub_iluthrs',     p_choice%thr2,      info,pos='post')
-      end select
-    end if
-
-    call prec%set('coarse_solve',    p_choice%csolve,    info)
-    call prec%set('coarse_mat',      p_choice%cmat,      info)
-     ! Set for the case of a KRM solver
-    if (psb_toupper(p_choice%csolve) == 'KRM') then
-      call prec%set('krm_method', p_choice%krm_method, info)
-      call prec%set('krm_kprec', p_choice%krm_prec,   info)
-      call prec%set('krm_sub_solve', p_choice%krm_subsolve, info)
-      call prec%set('krm_global', p_choice%krm_global, info)
-      call prec%set('krm_eps',   p_choice%krm_eps,   info)
-      call prec%set('krm_irst',   p_choice%krm_irst,   info)
-      call prec%set('krm_istopc',  p_choice%krm_istop,  info)
-      call prec%set('krm_itmax',  p_choice%krm_itmax,  info)
-      call prec%set('krm_itrace', p_choice%krm_itrace, info)
-      call prec%set('krm_fillin', p_choice%krm_fillin, info)
-    else
-      if (psb_toupper(p_choice%csolve) == 'BJAC') &
-        &  call prec%set('coarse_subsolve', p_choice%csbsolve,  info)
-      call prec%set('coarse_fillin',   p_choice%cfill,     info)
-      call prec%set('coarse_iluthrs',  p_choice%cthres,    info)
-      call prec%set('coarse_sweeps',   p_choice%cjswp,     info)
-    end if
-  end select
-
-  ! build the preconditioner
-  call psb_barrier(ctxt)
-  t1 = psb_wtime()
-  call prec%hierarchy_build(a,desc_a,info)
-  thier = psb_wtime()-t1
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_hierarchy_bld')
-    goto 9999
-  end if
-  call psb_barrier(ctxt)
-  t1 = psb_wtime()
-  call prec%smoothers_build(a,desc_a,info)
-  tsmth = psb_wtime()-t1
-  if (info /= psb_success_) then
-    call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_smoothers_bld')
-    goto 9999
-  end if
-
-  call psb_amx(ctxt, thier)
-  call psb_amx(ctxt, tprec)
-
-  if(iam == psb_root_) then
-    write(psb_out_unit,'(" ")')
-    write(psb_out_unit,'("Preconditioner: ",a)') trim(p_choice%descr)
-    write(psb_out_unit,'("Preconditioner time: ",es12.5)')thier+tprec
-    write(psb_out_unit,'(" ")')
-  end if
-
-  if (p_choice%dump) then
-    call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,&
-         & ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,&
-         & smoother=p_choice%dump_smoother, solver=p_choice%dump_solver, &
-         & global_num=p_choice%dump_global_num)    
-  end if
-  !
-  ! iterative method parameters
-  !
-  call psb_barrier(ctxt)
-  t1 = psb_wtime()
-  select case(psb_toupper(trim(s_choice%kmethd)))
-  case('RICHARDSON')
-    call psb_richardson(a,prec,b,x,s_choice%eps,&
-         & desc_a,info,itmax=s_choice%itmax,iter=iter,&
-         & err=err,itrace=s_choice%itrace,&
-         & istop=s_choice%istopc)
-  case('BICGSTAB','BICGSTABL','BICG','CG','CGS','FCG','GCR','RGMRES')
-    call psb_krylov(s_choice%kmethd,a,prec,b,x,s_choice%eps,&
-         & desc_a,info,itmax=s_choice%itmax,iter=iter,err=err,itrace=s_choice%itrace,&
-         & istop=s_choice%istopc,irst=s_choice%irst)
-  case default
-    write(psb_err_unit,*) 'Unknown method :"',trim(s_choice%kmethd),'"'
-    info=psb_err_invalid_input_
-    call psb_errpush(info,name)
-    goto 9999
-  end select
-  call psb_barrier(ctxt)
-  tslv = psb_wtime() - t1
-
-  call psb_amx(ctxt,tslv)
-
-  if(info /= psb_success_) then
-    info=psb_err_from_subroutine_
-    ch_err='solver routine'
-    call psb_errpush(info,name,a_err=ch_err)
-    goto 9999
-  end if
-
-  call psb_barrier(ctxt)
-  tslv = psb_wtime() - t1
-  call psb_amx(ctxt,tslv)
-
-  ! compute residual norms
-  call psb_geall(r,desc_a,info)
-  call r%zero()
-  call psb_geasb(r,desc_a,info)
-  call psb_geaxpby(done,b,dzero,r,desc_a,info)
-  call psb_spmm(-done,a,x,done,r,desc_a,info)
-  resmx  = psb_genrm2(r,desc_a,info)
-  resmxp = psb_geamax(r,desc_a,info)
-
-  vecsize = x%sizeof()
-  amatsize = a%sizeof()
-  descsize = desc_a%sizeof()
-  precsize = prec%sizeof()
-  system_size = desc_a%get_global_rows()
-  call psb_sum(ctxt,vecsize)
-  call psb_sum(ctxt,amatsize)
-  call psb_sum(ctxt,descsize)
-  call psb_sum(ctxt,precsize)
-  call prec%descr(info,iout=psb_out_unit)
-  if (iam == psb_root_) then
-    write(psb_out_unit,'("Computed solution on ",i8," process(es)")')  np
-    write(psb_out_unit,'("Number of threads                  : ",i12)') nth
-    write(psb_out_unit,'("Total number of tasks              : ",i12)') nth*np
-    write(psb_out_unit,'("Discretization domain size         : ",i12)') idim
-    write(psb_out_unit,'("Linear system size                 : ",i12)') system_size
-    write(psb_out_unit,'("PDE Coefficients                   : ",a)') trim(pdecoeff)
-    write(psb_out_unit,'("Problem setup time                 : ",es12.5)') tpgen
-    write(psb_out_unit,'("Krylov method                      : ",a)') trim(s_choice%kmethd)
-    write(psb_out_unit,'("Preconditioner                     : ",a)') trim(p_choice%descr)
-    write(psb_out_unit,'("Iterations to convergence          : ",i12)')    iter
-    write(psb_out_unit,'("Relative error estimate on exit    : ",es12.5)') err
-    write(psb_out_unit,'("Number of levels in hierarchy      : ",i12)')    prec%get_nlevs()
-    write(psb_out_unit,'("Time to build hierarchy            : ",es12.5)') thier
-    write(psb_out_unit,'("Time to build smoothers            : ",es12.5)') tsmth
-    write(psb_out_unit,'("Total preconditioner setup time    : ",es12.5)') tsmth+thier
-    write(psb_out_unit,'("Time to solve system               : ",es12.5)') tslv
-    write(psb_out_unit,'("Time per iteration                 : ",es12.5)') tslv/iter
-    write(psb_out_unit,'("Total time                         : ",es12.5)') tslv+tprec+thier
-    write(psb_out_unit,'("Residual 2-norm                    : ",es12.5)') resmx
-    write(psb_out_unit,'("Residual inf-norm                  : ",es12.5)') resmxp
-    write(psb_out_unit,'("Total memory occupation for X      : ",i16)') vecsize
-    write(psb_out_unit,'("Total memory occupation for A      : ",i16)') amatsize
-    write(psb_out_unit,'("Total memory occupation for DESC_A : ",i16)') descsize
-    write(psb_out_unit,'("Total memory occupation for PREC   : ",i16)') precsize
-    write(psb_out_unit,'("Total memory occupation            : ",i16)') &
-         & amatsize + descsize+precsize+2*vecsize    
-    write(psb_out_unit,'("Storage format for A               : ",a  )') a%get_fmt()
-    write(psb_out_unit,'("Storage format for DESC_A          : ",a  )') desc_a%get_fmt()
-
-  end if
-
-  !
-  !  cleanup storage and exit
-  !
-  call psb_gefree(b,desc_a,info)
-  call psb_gefree(x,desc_a,info)
-  call psb_spfree(a,desc_a,info)
-  call prec%free(info)
-  call psb_cdfree(desc_a,info)
-  if(info /= psb_success_) then
-    info=psb_err_from_subroutine_
-    ch_err='free routine'
-    call psb_errpush(info,name,a_err=ch_err)
-    goto 9999
-  end if
-  call psb_exit(ctxt)
-  stop
-
-9999 continue
-  call psb_error(ctxt)
-
-contains
-  !
-  ! get iteration parameters from standard input
-  !
-  !
-  ! get iteration parameters from standard input
-  !
-  subroutine get_parms(ctxt,afmt,idim,solve,prec,pdecoeff)
-
-    implicit none
-
-    type(psb_ctxt_type) :: ctxt
-    integer(psb_ipk_)   :: idim
-    character(len=*)    :: afmt
-    type(solverdata)    :: solve
-    type(precdata)      :: prec
-    character(len=*)    :: pdecoeff
-    integer(psb_ipk_)   :: iam, nm, np, inp_unit
-    character(len=1024)   :: filename
-
-    call psb_info(ctxt,iam,np)
-
-    if (iam == psb_root_) then
-      if (command_argument_count()>0) then
-        call get_command_argument(1,filename)
-        inp_unit = 30
-        open(inp_unit,file=filename,action='read',iostat=info)
-        if (info /= 0) then
-          write(psb_err_unit,*) 'Could not open file ',filename,' for input'
-          call psb_abort(ctxt)
-          stop
-        else
-          write(psb_err_unit,*) 'Opened file ',trim(filename),' for input'
-        end if
-      else
-        write(psb_err_unit,*) 'Usage: amg_d_pde2d ctrl-file '
-        call psb_abort(ctxt)
-        stop        
-      end if
-      ! read input data
-      !
-      call read_data(afmt,inp_unit)            ! matrix storage format
-      call read_data(idim,inp_unit)            ! Discretization grid size
-      call read_data(pdecoeff,inp_unit)        ! PDE Coefficients
-      ! Krylov solver data
-      call read_data(solve%kmethd,inp_unit)    ! Krylov solver
-      call read_data(solve%istopc,inp_unit)    ! stopping criterion
-      call read_data(solve%itmax,inp_unit)     ! max num iterations
-      call read_data(solve%itrace,inp_unit)    ! tracing
-      call read_data(solve%irst,inp_unit)      ! restart
-      call read_data(solve%eps,inp_unit)       ! tolerance
-      ! preconditioner type
-      call read_data(prec%descr,inp_unit)      ! verbose description of the prec
-      call read_data(prec%ptype,inp_unit)      ! preconditioner type
-      
-      ! First smoother / 1-lev preconditioner
-      call read_data(prec%smther,inp_unit)     ! smoother type
-      call read_data(prec%jsweeps,inp_unit)    ! (pre-)smoother / 1-lev prec sweeps
-      call read_data(prec%degree,inp_unit)     ! (pre-)smoother / 1-lev prec sweeps
-      call read_data(prec%pvariant,inp_unit)   !
-      call read_data(prec%prhovariant,inp_unit)! how to estimate rho(M^{-1}A)
-      call read_data(prec%prhovalue,inp_unit)  ! if previous is set value, we set it from this one
-      call read_data(prec%novr,inp_unit)       ! number of overlap layers
-      call read_data(prec%restr,inp_unit)      ! restriction  over application of AS
-      call read_data(prec%prol,inp_unit)       ! prolongation over application of AS
-      call read_data(prec%solve,inp_unit)      ! local subsolver
-      call read_data(prec%ssweeps,inp_unit)    ! inner solver sweeps 
-      call read_data(prec%variant,inp_unit)    ! AINV variant
-      call read_data(prec%fill,inp_unit)       ! fill-in for incomplete LU
-      call read_data(prec%invfill,inp_unit)    !Inverse fill-in for INVK
-      call read_data(prec%thr,inp_unit)        ! threshold for ILUT
-      ! Second smoother/ AMG post-smoother (if NONE ignored in main)
-      call read_data(prec%smther2,inp_unit)     ! smoother type
-      call read_data(prec%jsweeps2,inp_unit)    ! (post-)smoother sweeps
-      call read_data(prec%degree2,inp_unit)    ! (post-)smoother sweeps
-      call read_data(prec%pvariant2,inp_unit)   !
-      call read_data(prec%prhovariant2,inp_unit)! how to estimate rho(M^{-1}A)
-      call read_data(prec%prhovalue2,inp_unit)  ! if previous is set value, we set it from this one
-      call read_data(prec%novr2,inp_unit)       ! number of overlap layers
-      call read_data(prec%restr2,inp_unit)      ! restriction  over application of AS
-      call read_data(prec%prol2,inp_unit)       ! prolongation over application of AS
-      call read_data(prec%solve2,inp_unit)      ! local subsolver
-      call read_data(prec%ssweeps2,inp_unit)    ! inner solver sweeps
-      call read_data(prec%variant2,inp_unit)    ! AINV variant
-      call read_data(prec%fill2,inp_unit)       ! fill-in for incomplete LU
-      call read_data(prec%invfill2,inp_unit)    !Inverse fill-in for INVK
-      call read_data(prec%thr2,inp_unit)        ! threshold for ILUT
-      ! general AMG data
-      call read_data(prec%mlcycle,inp_unit)     ! AMG cycle type
-      call read_data(prec%outer_sweeps,inp_unit) ! number of 1lev/outer sweeps
-      call read_data(prec%maxlevs,inp_unit)    ! max number of levels in AMG prec
-      call read_data(prec%csizepp,inp_unit)       ! min size coarsest mat
-      ! aggregation
-      call read_data(prec%aggr_prol,inp_unit)    ! aggregation type
-      call read_data(prec%par_aggr_alg,inp_unit)    ! parallel aggregation alg
-      call read_data(prec%aggr_type,inp_unit)   ! type of aggregation
-      call read_data(prec%aggr_size,inp_unit) ! Requested size of the aggregates for MATCHBOXP
-      call read_data(prec%aggr_ord,inp_unit)    ! ordering for aggregation
-      call read_data(prec%mncrratio,inp_unit)  ! minimum aggregation ratio
-      call read_data(prec%aggr_filter,inp_unit) ! filtering
-      call read_data(prec%athres,inp_unit)      ! smoothed aggr thresh
-      call read_data(prec%thrvsz,inp_unit)      ! size of aggr thresh vector
-      if (prec%thrvsz > 0) then
-        call psb_realloc(prec%thrvsz,prec%athresv,info)
-        call read_data(prec%athresv,inp_unit)   ! aggr thresh vector
-      else
-        read(inp_unit,*)                        ! dummy read to skip a record
-      end if
-      ! coasest-level solver
-      call read_data(prec%csolve,inp_unit)      ! coarsest-lev solver
-      call read_data(prec%csbsolve,inp_unit)    ! coarsest-lev subsolver
-      call read_data(prec%cmat,inp_unit)        ! coarsest mat layout
-      call read_data(prec%cfill,inp_unit)       ! fill-in for incompl LU
-      call read_data(prec%cthres,inp_unit)      ! Threshold for ILUT
-      call read_data(prec%cjswp,inp_unit)       ! sweeps for GS/JAC subsolver
-      ! Krylov method for coarsest level
-      call read_data(prec%krm_method,inp_unit)  ! Krylov method for coarsest level
-      call read_data(prec%krm_prec,inp_unit)    ! Preconditioner for coarsest level
-      call read_data(prec%krm_subsolve,inp_unit) ! Subsolver for coarsest level
-      call read_data(prec%krm_global,inp_unit)  ! Is the solver global or local? TRUE or FALSE
-      call read_data(prec%krm_eps,inp_unit)     ! Stopping tolerance
-      call read_data(prec%krm_irst,inp_unit)    ! Restart for Krylov method
-      call read_data(prec%krm_istop,inp_unit)   ! Stopping criterion
-      call read_data(prec%krm_itmax,inp_unit)   ! Maximum number of iterations
-      call read_data(prec%krm_itrace,inp_unit)  ! Trace of the lower Krylov iterations
-      call read_data(prec%krm_fillin,inp_unit)  ! Fill-in for incomplete LU factorization
-      ! dump 
-      call read_data(prec%dump,inp_unit)       ! Dump on file?
-      call read_data(prec%dlmin,inp_unit)      ! Minimum level to dump
-      call read_data(prec%dlmax,inp_unit)      ! Maximum level to dump
-      call read_data(prec%dump_ac,inp_unit)       
-      call read_data(prec%dump_rp,inp_unit)       
-      call read_data(prec%dump_tprol,inp_unit)    
-      call read_data(prec%dump_smoother,inp_unit) 
-      call read_data(prec%dump_solver,inp_unit)   
-      call read_data(prec%dump_global_num,inp_unit)
-
-      if (inp_unit /= psb_inp_unit) then
-        close(inp_unit)
-      end if
-    end if
-
-    call psb_bcast(ctxt,afmt)
-    call psb_bcast(ctxt,idim)
-    call psb_bcast(ctxt,pdecoeff)
-
-    call psb_bcast(ctxt,solve%kmethd)
-    call psb_bcast(ctxt,solve%istopc)
-    call psb_bcast(ctxt,solve%itmax)
-    call psb_bcast(ctxt,solve%itrace)
-    call psb_bcast(ctxt,solve%irst)
-    call psb_bcast(ctxt,solve%eps)
-
-    call psb_bcast(ctxt,prec%descr)
-    call psb_bcast(ctxt,prec%ptype)
-
-    ! broadcast first (pre-)smoother / 1-lev prec data
-    call psb_bcast(ctxt,prec%smther)
-    call psb_bcast(ctxt,prec%jsweeps)
-    call psb_bcast(ctxt,prec%degree)
-    call psb_bcast(ctxt,prec%pvariant)
-    call psb_bcast(ctxt,prec%prhovariant)
-    call psb_bcast(ctxt,prec%prhovalue)  
-    call psb_bcast(ctxt,prec%novr)
-    call psb_bcast(ctxt,prec%restr)
-    call psb_bcast(ctxt,prec%prol)
-    call psb_bcast(ctxt,prec%solve)
-    call psb_bcast(ctxt,prec%ssweeps)
-    call psb_bcast(ctxt,prec%variant)
-    call psb_bcast(ctxt,prec%fill)
-    call psb_bcast(ctxt,prec%invfill)
-    call psb_bcast(ctxt,prec%thr)
-    ! broadcast second (post-)smoother
-    call psb_bcast(ctxt,prec%smther2)
-    call psb_bcast(ctxt,prec%jsweeps2)
-    call psb_bcast(ctxt,prec%degree2)
-    call psb_bcast(ctxt,prec%pvariant2)
-    call psb_bcast(ctxt,prec%prhovariant2)
-    call psb_bcast(ctxt,prec%prhovalue2)  
-    call psb_bcast(ctxt,prec%novr2)
-    call psb_bcast(ctxt,prec%restr2)
-    call psb_bcast(ctxt,prec%prol2)
-    call psb_bcast(ctxt,prec%solve2)
-    call psb_bcast(ctxt,prec%ssweeps2)
-    call psb_bcast(ctxt,prec%variant2)
-    call psb_bcast(ctxt,prec%fill2)
-    call psb_bcast(ctxt,prec%invfill2)
-    call psb_bcast(ctxt,prec%thr2)
-
-    ! broadcast AMG parameters
-    call psb_bcast(ctxt,prec%mlcycle)
-    call psb_bcast(ctxt,prec%outer_sweeps)
-    call psb_bcast(ctxt,prec%maxlevs)
-    call psb_bcast(ctxt,prec%csizepp)
-
-    call psb_bcast(ctxt,prec%aggr_prol)
-    call psb_bcast(ctxt,prec%par_aggr_alg)
-    call psb_bcast(ctxt,prec%aggr_type)
-    call psb_bcast(ctxt,prec%aggr_size)
-    call psb_bcast(ctxt,prec%aggr_ord)
-    call psb_bcast(ctxt,prec%aggr_filter)
-    call psb_bcast(ctxt,prec%mncrratio)
-    call psb_bcast(ctxt,prec%thrvsz)
-    if (prec%thrvsz > 0) then
-      if (iam /= psb_root_) call psb_realloc(prec%thrvsz,prec%athresv,info)
-      call psb_bcast(ctxt,prec%athresv)
-    end if
-    call psb_bcast(ctxt,prec%athres)
-
-    call psb_bcast(ctxt,prec%cmat)
-    call psb_bcast(ctxt,prec%csolve)
-    call psb_bcast(ctxt,prec%csbsolve)
-    call psb_bcast(ctxt,prec%cfill)
-    call psb_bcast(ctxt,prec%cthres)
-    call psb_bcast(ctxt,prec%cjswp)
-    ! Krylov method for coarsest level (broadcast)
-    call psb_bcast(ctxt,prec%krm_method)
-    call psb_bcast(ctxt,prec%krm_prec)
-    call psb_bcast(ctxt,prec%krm_subsolve)
-    call psb_bcast(ctxt,prec%krm_global)
-    call psb_bcast(ctxt,prec%krm_eps)
-    call psb_bcast(ctxt,prec%krm_irst)
-    call psb_bcast(ctxt,prec%krm_istop)
-    call psb_bcast(ctxt,prec%krm_itmax)
-    call psb_bcast(ctxt,prec%krm_itrace)
-    call psb_bcast(ctxt,prec%krm_fillin)
-    ! dump
-    call psb_bcast(ctxt,prec%dump)
-    call psb_bcast(ctxt,prec%dlmin)
-    call psb_bcast(ctxt,prec%dlmax)
-
-    call psb_bcast(ctxt,prec%dump_ac)       
-    call psb_bcast(ctxt,prec%dump_rp)       
-    call psb_bcast(ctxt,prec%dump_tprol)    
-    call psb_bcast(ctxt,prec%dump_smoother) 
-    call psb_bcast(ctxt,prec%dump_solver)   
-    call psb_bcast(ctxt,prec%dump_global_num)
-
-
-  end subroutine get_parms
-
-end program amg_d_pde2d

samples/advanced/remap/amg_d_pde2d_box_mod.f90

@@ -1,89 +0,0 @@
-!
-!
-!                             AMG4PSBLAS version 1.0
-!    Algebraic Multigrid Package
-!               based on PSBLAS (Parallel Sparse BLAS version 3.7)
-!
-!    (C) Copyright 2021
-!
-!        Salvatore Filippone
-!        Pasqua D'Ambra
-!        Fabio Durastante
-!
-!    Redistribution and use in source and binary forms, with or without
-!    modification, are permitted provided that the following conditions
-!    are met:
-!      1. Redistributions of source code must retain the above copyright
-!         notice, this list of conditions and the following disclaimer.
-!      2. Redistributions in binary form must reproduce the above copyright
-!         notice, this list of conditions, and the following disclaimer in the
-!         documentation and/or other materials provided with the distribution.
-!      3. The name of the AMG4PSBLAS group or the names of its contributors may
-!         not be used to endorse or promote products derived from this
-!         software without specific prior written permission.
-!
-!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
-!    BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-!    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-!    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-!    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-!    CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-!    ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-!    POSSIBILITY OF SUCH DAMAGE.
-!
-module amg_d_pde2d_box_mod
-  use psb_base_mod, only : psb_dpk_, dzero, done
-  real(psb_dpk_), save, private :: epsilon=done/80
-contains
-  subroutine pde_set_parm2d_box(dat)
-    real(psb_dpk_), intent(in) :: dat
-    epsilon = dat
-  end subroutine pde_set_parm2d_box
-  !
-  ! functions parametrizing the differential equation
-  !
-  function b1_box(x,y)
-    implicit none 
-    real(psb_dpk_) :: b1_box
-    real(psb_dpk_), intent(in) :: x,y
-    b1_box = done/1.414_psb_dpk_
-  end function b1_box
-  function b2_box(x,y)
-    implicit none 
-    real(psb_dpk_) ::  b2_box
-    real(psb_dpk_), intent(in) :: x,y
-    b2_box = done/1.414_psb_dpk_
-  end function b2_box
-  function c_box(x,y)
-    implicit none 
-    real(psb_dpk_) ::  c_box
-    real(psb_dpk_), intent(in) :: x,y
-    c_box = dzero
-  end function c_box
-  function a1_box(x,y)
-    implicit none 
-    real(psb_dpk_) ::  a1_box
-    real(psb_dpk_), intent(in) :: x,y
-    a1_box=done*epsilon
-  end function a1_box
-  function a2_box(x,y)
-    implicit none 
-    real(psb_dpk_) ::  a2_box
-    real(psb_dpk_), intent(in) :: x,y
-    a2_box=done*epsilon
-  end function a2_box
-  function g_box(x,y)
-    implicit none 
-    real(psb_dpk_) ::  g_box
-    real(psb_dpk_), intent(in) :: x,y
-    g_box = dzero
-    if (x == done) then
-      g_box = done
-    else if (x == dzero) then
-      g_box = done
-    end if
-  end function g_box
-end module amg_d_pde2d_box_mod

samples/advanced/remap/amg_d_pde2d_exp_mod.f90

@@ -1,89 +0,0 @@
-!
-!
-!                             AMG4PSBLAS version 1.0
-!    Algebraic Multigrid Package
-!               based on PSBLAS (Parallel Sparse BLAS version 3.7)
-!
-!    (C) Copyright 2021
-!
-!        Salvatore Filippone
-!        Pasqua D'Ambra
-!        Fabio Durastante
-!
-!    Redistribution and use in source and binary forms, with or without
-!    modification, are permitted provided that the following conditions
-!    are met:
-!      1. Redistributions of source code must retain the above copyright
-!         notice, this list of conditions and the following disclaimer.
-!      2. Redistributions in binary form must reproduce the above copyright
-!         notice, this list of conditions, and the following disclaimer in the
-!         documentation and/or other materials provided with the distribution.
-!      3. The name of the AMG4PSBLAS group or the names of its contributors may
-!         not be used to endorse or promote products derived from this
-!         software without specific prior written permission.
-!
-!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
-!    BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-!    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-!    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-!    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-!    CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-!    ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-!    POSSIBILITY OF SUCH DAMAGE.
-!
-module amg_d_pde2d_exp_mod
-  use psb_base_mod, only : psb_dpk_, done, dzero
-  real(psb_dpk_), save, private :: epsilon=done/80
-contains
-  subroutine pde_set_parm2d_exp(dat)
-    real(psb_dpk_), intent(in) :: dat
-    epsilon = dat
-  end subroutine pde_set_parm2d_exp
-  !
-  ! functions parametrizing the differential equation
-  !
-  function b1_exp(x,y)
-    implicit none 
-    real(psb_dpk_) :: b1_exp
-    real(psb_dpk_), intent(in) :: x,y
-    b1_exp = dzero
-  end function b1_exp
-  function b2_exp(x,y)
-    implicit none 
-    real(psb_dpk_) ::  b2_exp
-    real(psb_dpk_), intent(in) :: x,y
-    b2_exp = dzero
-  end function b2_exp
-  function c_exp(x,y)
-    implicit none 
-    real(psb_dpk_) ::  c_exp
-    real(psb_dpk_), intent(in) :: x,y
-    c_exp = dzero
-  end function c_exp
-  function a1_exp(x,y)
-    implicit none 
-    real(psb_dpk_) ::  a1_exp
-    real(psb_dpk_), intent(in) :: x,y
-    a1_exp=done*epsilon*exp(-(x+y))
-  end function a1_exp
-  function a2_exp(x,y)
-    implicit none 
-    real(psb_dpk_) ::  a2_exp
-    real(psb_dpk_), intent(in) :: x,y
-    a2_exp=done*epsilon*exp(-(x+y))
-  end function a2_exp
-  function g_exp(x,y)
-    implicit none 
-    real(psb_dpk_) ::  g_exp
-    real(psb_dpk_), intent(in) :: x,y
-    g_exp = dzero
-    if (x == done) then
-      g_exp = done
-    else if (x == dzero) then
-      g_exp = done
-    end if
-  end function g_exp
-end module amg_d_pde2d_exp_mod

samples/advanced/remap/amg_d_pde2d_gauss_mod.f90

@@ -1,89 +0,0 @@
-!
-!
-!                             AMG4PSBLAS version 1.0
-!    Algebraic Multigrid Package
-!               based on PSBLAS (Parallel Sparse BLAS version 3.7)
-!
-!    (C) Copyright 2021
-!
-!        Salvatore Filippone
-!        Pasqua D'Ambra
-!        Fabio Durastante
-!
-!    Redistribution and use in source and binary forms, with or without
-!    modification, are permitted provided that the following conditions
-!    are met:
-!      1. Redistributions of source code must retain the above copyright
-!         notice, this list of conditions and the following disclaimer.
-!      2. Redistributions in binary form must reproduce the above copyright
-!         notice, this list of conditions, and the following disclaimer in the
-!         documentation and/or other materials provided with the distribution.
-!      3. The name of the AMG4PSBLAS group or the names of its contributors may
-!         not be used to endorse or promote products derived from this
-!         software without specific prior written permission.
-!
-!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
-!    BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-!    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-!    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-!    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-!    CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-!    ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-!    POSSIBILITY OF SUCH DAMAGE.
-!
-module amg_d_pde2d_gauss_mod
-  use psb_base_mod, only : psb_dpk_, done, dzero
-  real(psb_dpk_), save, private :: epsilon=done/80
-contains
-  subroutine pde_set_parm2d_gauss(dat)
-    real(psb_dpk_), intent(in) :: dat
-    epsilon = dat
-  end subroutine pde_set_parm2d_gauss
-  !
-  ! functions parametrizing the differential equation
-  !
-  function b1_gauss(x,y)
-    implicit none 
-    real(psb_dpk_) :: b1_gauss
-    real(psb_dpk_), intent(in) :: x,y
-    b1_gauss=done/sqrt(3.0_psb_dpk_)-2*x*exp(-(x**2+y**2))
-  end function b1_gauss
-  function b2_gauss(x,y)
-    implicit none 
-    real(psb_dpk_) ::  b2_gauss
-    real(psb_dpk_), intent(in) :: x,y
-    b2_gauss=done/sqrt(3.0_psb_dpk_)-2*y*exp(-(x**2+y**2))
-  end function b2_gauss
-  function c_gauss(x,y)
-    implicit none 
-    real(psb_dpk_) ::  c_gauss
-    real(psb_dpk_), intent(in) :: x,y
-    c_gauss=dzero
-  end function c_gauss
-  function a1_gauss(x,y)
-    implicit none 
-    real(psb_dpk_) ::  a1_gauss
-    real(psb_dpk_), intent(in) :: x,y
-    a1_gauss=epsilon*exp(-(x**2+y**2))
-  end function a1_gauss
-  function a2_gauss(x,y)
-    implicit none 
-    real(psb_dpk_) ::  a2_gauss
-    real(psb_dpk_), intent(in) :: x,y
-    a2_gauss=epsilon*exp(-(x**2+y**2))
-  end function a2_gauss
-  function g_gauss(x,y)
-    implicit none 
-    real(psb_dpk_) ::  g_gauss
-    real(psb_dpk_), intent(in) :: x,y
-    g_gauss = dzero
-    if (x == done) then
-      g_gauss = done
-    else if (x == dzero) then
-      g_gauss = done
-    end if
-  end function g_gauss
-end module amg_d_pde2d_gauss_mod

samples/advanced/remap/amg_d_pde2d_poisson_mod.f90

@@ -1,89 +0,0 @@
-!
-!
-!                             AMG4PSBLAS version 1.0
-!    Algebraic Multigrid Package
-!               based on PSBLAS (Parallel Sparse BLAS version 3.7)
-!
-!    (C) Copyright 2021
-!
-!        Salvatore Filippone
-!        Pasqua D'Ambra
-!        Fabio Durastante
-!
-!    Redistribution and use in source and binary forms, with or without
-!    modification, are permitted provided that the following conditions
-!    are met:
-!      1. Redistributions of source code must retain the above copyright
-!         notice, this list of conditions and the following disclaimer.
-!      2. Redistributions in binary form must reproduce the above copyright
-!         notice, this list of conditions, and the following disclaimer in the
-!         documentation and/or other materials provided with the distribution.
-!      3. The name of the AMG4PSBLAS group or the names of its contributors may
-!         not be used to endorse or promote products derived from this
-!         software without specific prior written permission.
-!
-!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
-!    BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-!    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-!    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-!    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-!    CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-!    ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-!    POSSIBILITY OF SUCH DAMAGE.
-!
-module amg_d_pde2d_poisson_mod
-  use psb_base_mod, only : psb_dpk_, dzero, done
-  real(psb_dpk_), save, private :: epsilon=done/80
-contains
-  subroutine pde_set_parm2d_poisson(dat)
-    real(psb_dpk_), intent(in) :: dat
-    epsilon = dat
-  end subroutine pde_set_parm2d_poisson
-  !
-  ! functions parametrizing the differential equation
-  !
-  function b1_poisson(x,y)
-    implicit none 
-    real(psb_dpk_) :: b1_poisson
-    real(psb_dpk_), intent(in) :: x,y
-    b1_poisson = dzero
-  end function b1_poisson
-  function b2_poisson(x,y)
-    implicit none 
-    real(psb_dpk_) ::  b2_poisson
-    real(psb_dpk_), intent(in) :: x,y
-    b2_poisson = dzero
-  end function b2_poisson
-  function c_poisson(x,y)
-    implicit none 
-    real(psb_dpk_) ::  c_poisson
-    real(psb_dpk_), intent(in) :: x,y
-    c_poisson = dzero
-  end function c_poisson
-  function a1_poisson(x,y)
-    implicit none 
-    real(psb_dpk_) ::  a1_poisson
-    real(psb_dpk_), intent(in) :: x,y
-    a1_poisson=done*epsilon
-  end function a1_poisson
-  function a2_poisson(x,y)
-    implicit none 
-    real(psb_dpk_) ::  a2_poisson
-    real(psb_dpk_), intent(in) :: x,y
-    a2_poisson=done*epsilon
-  end function a2_poisson
-  function g_poisson(x,y)
-    implicit none 
-    real(psb_dpk_) ::  g_poisson
-    real(psb_dpk_), intent(in) :: x,y
-    g_poisson = dzero
-    if (x == done) then
-      g_poisson = done
-    else if (x == dzero) then
-      g_poisson = done
-    end if
-  end function g_poisson
-end module amg_d_pde2d_poisson_mod