Merge branch 'unify_aggr_bld' into development

base/modules/auxil/psb_c_realloc_mod.F90

@@ -39,6 +39,7 @@ module psb_c_realloc_mod
   ! the size specified, possibly shortening it. 
   !
   Interface psb_realloc
+    module procedure psb_r_c_s
     module procedure psb_r_m_c_rk1
     module procedure psb_r_m_c_rk2
     module procedure psb_r_e_c_rk1
@@ -56,7 +57,7 @@ module psb_c_realloc_mod
   end interface psb_move_alloc
 
   Interface psb_safe_ab_cpy
-    module procedure psb_ab_cpy_c_rk1, psb_ab_cpy_c_rk2
+    module procedure psb_ab_cpy_c_s, psb_ab_cpy_c_rk1, psb_ab_cpy_c_rk2
   end Interface psb_safe_ab_cpy
 
   Interface psb_safe_cpy
@@ -82,6 +83,42 @@ module psb_c_realloc_mod
 
 Contains
 
+  Subroutine psb_r_c_s(rrax,info)
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    complex(psb_spk_), allocatable, intent(inout) :: rrax
+    integer(psb_ipk_) :: info
+
+    ! ...Local Variables
+    integer(psb_ipk_) :: err_act,err
+    character(len=20)  :: name
+    logical, parameter :: debug=.false.
+
+    name='psb_r_c_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_ 
+
+    if (.not.allocated(rrax)) then 
+      Allocate(rrax,stat=info)
+      if (info /= psb_success_) then
+        err=4025
+        call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
+             & a_err='complex(psb_spk_)')
+        goto 9999
+      end if
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    info = err
+    call psb_error_handler(err_act)
+    return
+
+  End Subroutine psb_r_c_s
+
   Subroutine psb_r_m_c_rk1(len,rrax,info,pad,lb)
     use psb_error_mod
 
@@ -687,6 +724,48 @@ Contains
 
 
 
+  subroutine psb_ab_cpy_c_s(vin,vout,info) 
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    complex(psb_spk_), allocatable, intent(in)  :: vin
+    complex(psb_spk_), allocatable, intent(out) :: vout
+    integer(psb_ipk_) :: info
+    ! ...Local Variables
+
+    integer(psb_ipk_) :: isz,err_act,lb
+    character(len=20)  :: name, char_err
+    logical, parameter :: debug=.false.
+
+    name='psb_ab_cpy_c_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_
+    if(psb_errstatus_fatal()) then 
+      info=psb_err_from_subroutine_
+      goto 9999
+    end if
+
+    if (allocated(vin)) then 
+      call psb_realloc(vout,info)
+      if (info /= psb_success_) then     
+        info=psb_err_from_subroutine_
+        char_err='psb_realloc'
+        call psb_errpush(info,name,a_err=char_err)
+        goto 9999
+      else
+        vout = vin
+      endif
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+
+    return
+
+  end subroutine psb_ab_cpy_c_s
+
   subroutine psb_ab_cpy_c_rk1(vin,vout,info) 
     use psb_error_mod
 

base/modules/auxil/psb_d_realloc_mod.F90

@@ -39,6 +39,7 @@ module psb_d_realloc_mod
   ! the size specified, possibly shortening it. 
   !
   Interface psb_realloc
+    module procedure psb_r_d_s
     module procedure psb_r_m_d_rk1
     module procedure psb_r_m_d_rk2
     module procedure psb_r_e_d_rk1
@@ -56,7 +57,7 @@ module psb_d_realloc_mod
   end interface psb_move_alloc
 
   Interface psb_safe_ab_cpy
-    module procedure psb_ab_cpy_d_rk1, psb_ab_cpy_d_rk2
+    module procedure psb_ab_cpy_d_s, psb_ab_cpy_d_rk1, psb_ab_cpy_d_rk2
   end Interface psb_safe_ab_cpy
 
   Interface psb_safe_cpy
@@ -82,6 +83,42 @@ module psb_d_realloc_mod
 
 Contains
 
+  Subroutine psb_r_d_s(rrax,info)
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    real(psb_dpk_), allocatable, intent(inout) :: rrax
+    integer(psb_ipk_) :: info
+
+    ! ...Local Variables
+    integer(psb_ipk_) :: err_act,err
+    character(len=20)  :: name
+    logical, parameter :: debug=.false.
+
+    name='psb_r_d_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_ 
+
+    if (.not.allocated(rrax)) then 
+      Allocate(rrax,stat=info)
+      if (info /= psb_success_) then
+        err=4025
+        call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
+             & a_err='real(psb_dpk_)')
+        goto 9999
+      end if
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    info = err
+    call psb_error_handler(err_act)
+    return
+
+  End Subroutine psb_r_d_s
+
   Subroutine psb_r_m_d_rk1(len,rrax,info,pad,lb)
     use psb_error_mod
 
@@ -687,6 +724,48 @@ Contains
 
 
 
+  subroutine psb_ab_cpy_d_s(vin,vout,info) 
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    real(psb_dpk_), allocatable, intent(in)  :: vin
+    real(psb_dpk_), allocatable, intent(out) :: vout
+    integer(psb_ipk_) :: info
+    ! ...Local Variables
+
+    integer(psb_ipk_) :: isz,err_act,lb
+    character(len=20)  :: name, char_err
+    logical, parameter :: debug=.false.
+
+    name='psb_ab_cpy_d_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_
+    if(psb_errstatus_fatal()) then 
+      info=psb_err_from_subroutine_
+      goto 9999
+    end if
+
+    if (allocated(vin)) then 
+      call psb_realloc(vout,info)
+      if (info /= psb_success_) then     
+        info=psb_err_from_subroutine_
+        char_err='psb_realloc'
+        call psb_errpush(info,name,a_err=char_err)
+        goto 9999
+      else
+        vout = vin
+      endif
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+
+    return
+
+  end subroutine psb_ab_cpy_d_s
+
   subroutine psb_ab_cpy_d_rk1(vin,vout,info) 
     use psb_error_mod
 

base/modules/auxil/psb_e_realloc_mod.F90

@@ -39,6 +39,7 @@ module psb_e_realloc_mod
   ! the size specified, possibly shortening it. 
   !
   Interface psb_realloc
+    module procedure psb_r_e_s
     module procedure psb_r_m_e_rk1
     module procedure psb_r_m_e_rk2
     module procedure psb_r_e_e_rk1
@@ -56,7 +57,7 @@ module psb_e_realloc_mod
   end interface psb_move_alloc
 
   Interface psb_safe_ab_cpy
-    module procedure psb_ab_cpy_e_rk1, psb_ab_cpy_e_rk2
+    module procedure psb_ab_cpy_e_s, psb_ab_cpy_e_rk1, psb_ab_cpy_e_rk2
   end Interface psb_safe_ab_cpy
 
   Interface psb_safe_cpy
@@ -82,6 +83,42 @@ module psb_e_realloc_mod
 
 Contains
 
+  Subroutine psb_r_e_s(rrax,info)
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    integer(psb_epk_), allocatable, intent(inout) :: rrax
+    integer(psb_ipk_) :: info
+
+    ! ...Local Variables
+    integer(psb_ipk_) :: err_act,err
+    character(len=20)  :: name
+    logical, parameter :: debug=.false.
+
+    name='psb_r_e_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_ 
+
+    if (.not.allocated(rrax)) then 
+      Allocate(rrax,stat=info)
+      if (info /= psb_success_) then
+        err=4025
+        call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
+             & a_err='integer(psb_epk_)')
+        goto 9999
+      end if
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    info = err
+    call psb_error_handler(err_act)
+    return
+
+  End Subroutine psb_r_e_s
+
   Subroutine psb_r_m_e_rk1(len,rrax,info,pad,lb)
     use psb_error_mod
 
@@ -687,6 +724,48 @@ Contains
 
 
 
+  subroutine psb_ab_cpy_e_s(vin,vout,info) 
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    integer(psb_epk_), allocatable, intent(in)  :: vin
+    integer(psb_epk_), allocatable, intent(out) :: vout
+    integer(psb_ipk_) :: info
+    ! ...Local Variables
+
+    integer(psb_ipk_) :: isz,err_act,lb
+    character(len=20)  :: name, char_err
+    logical, parameter :: debug=.false.
+
+    name='psb_ab_cpy_e_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_
+    if(psb_errstatus_fatal()) then 
+      info=psb_err_from_subroutine_
+      goto 9999
+    end if
+
+    if (allocated(vin)) then 
+      call psb_realloc(vout,info)
+      if (info /= psb_success_) then     
+        info=psb_err_from_subroutine_
+        char_err='psb_realloc'
+        call psb_errpush(info,name,a_err=char_err)
+        goto 9999
+      else
+        vout = vin
+      endif
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+
+    return
+
+  end subroutine psb_ab_cpy_e_s
+
   subroutine psb_ab_cpy_e_rk1(vin,vout,info) 
     use psb_error_mod
 

base/modules/auxil/psb_i2_realloc_mod.F90

@@ -39,6 +39,7 @@ module psb_i2_realloc_mod
   ! the size specified, possibly shortening it. 
   !
   Interface psb_realloc
+    module procedure psb_r_i2_s
     module procedure psb_r_m_i2_rk1
     module procedure psb_r_m_i2_rk2
     module procedure psb_r_e_i2_rk1
@@ -56,7 +57,7 @@ module psb_i2_realloc_mod
   end interface psb_move_alloc
 
   Interface psb_safe_ab_cpy
-    module procedure psb_ab_cpy_i2_rk1, psb_ab_cpy_i2_rk2
+    module procedure psb_ab_cpy_i2_s, psb_ab_cpy_i2_rk1, psb_ab_cpy_i2_rk2
   end Interface psb_safe_ab_cpy
 
   Interface psb_safe_cpy
@@ -82,6 +83,42 @@ module psb_i2_realloc_mod
 
 Contains
 
+  Subroutine psb_r_i2_s(rrax,info)
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    integer(psb_i2pk_), allocatable, intent(inout) :: rrax
+    integer(psb_ipk_) :: info
+
+    ! ...Local Variables
+    integer(psb_ipk_) :: err_act,err
+    character(len=20)  :: name
+    logical, parameter :: debug=.false.
+
+    name='psb_r_i2_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_ 
+
+    if (.not.allocated(rrax)) then 
+      Allocate(rrax,stat=info)
+      if (info /= psb_success_) then
+        err=4025
+        call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
+             & a_err='integer(psb_i2pk_)')
+        goto 9999
+      end if
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    info = err
+    call psb_error_handler(err_act)
+    return
+
+  End Subroutine psb_r_i2_s
+
   Subroutine psb_r_m_i2_rk1(len,rrax,info,pad,lb)
     use psb_error_mod
 
@@ -687,6 +724,48 @@ Contains
 
 
 
+  subroutine psb_ab_cpy_i2_s(vin,vout,info) 
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    integer(psb_i2pk_), allocatable, intent(in)  :: vin
+    integer(psb_i2pk_), allocatable, intent(out) :: vout
+    integer(psb_ipk_) :: info
+    ! ...Local Variables
+
+    integer(psb_ipk_) :: isz,err_act,lb
+    character(len=20)  :: name, char_err
+    logical, parameter :: debug=.false.
+
+    name='psb_ab_cpy_i2_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_
+    if(psb_errstatus_fatal()) then 
+      info=psb_err_from_subroutine_
+      goto 9999
+    end if
+
+    if (allocated(vin)) then 
+      call psb_realloc(vout,info)
+      if (info /= psb_success_) then     
+        info=psb_err_from_subroutine_
+        char_err='psb_realloc'
+        call psb_errpush(info,name,a_err=char_err)
+        goto 9999
+      else
+        vout = vin
+      endif
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+
+    return
+
+  end subroutine psb_ab_cpy_i2_s
+
   subroutine psb_ab_cpy_i2_rk1(vin,vout,info) 
     use psb_error_mod
 

base/modules/auxil/psb_m_realloc_mod.F90

@@ -39,6 +39,7 @@ module psb_m_realloc_mod
   ! the size specified, possibly shortening it. 
   !
   Interface psb_realloc
+    module procedure psb_r_m_s
     module procedure psb_r_m_m_rk1
     module procedure psb_r_m_m_rk2
     module procedure psb_r_e_m_rk1
@@ -56,7 +57,7 @@ module psb_m_realloc_mod
   end interface psb_move_alloc
 
   Interface psb_safe_ab_cpy
-    module procedure psb_ab_cpy_m_rk1, psb_ab_cpy_m_rk2
+    module procedure psb_ab_cpy_m_s, psb_ab_cpy_m_rk1, psb_ab_cpy_m_rk2
   end Interface psb_safe_ab_cpy
 
   Interface psb_safe_cpy
@@ -82,6 +83,42 @@ module psb_m_realloc_mod
 
 Contains
 
+  Subroutine psb_r_m_s(rrax,info)
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    integer(psb_mpk_), allocatable, intent(inout) :: rrax
+    integer(psb_ipk_) :: info
+
+    ! ...Local Variables
+    integer(psb_ipk_) :: err_act,err
+    character(len=20)  :: name
+    logical, parameter :: debug=.false.
+
+    name='psb_r_m_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_ 
+
+    if (.not.allocated(rrax)) then 
+      Allocate(rrax,stat=info)
+      if (info /= psb_success_) then
+        err=4025
+        call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
+             & a_err='integer(psb_mpk_)')
+        goto 9999
+      end if
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    info = err
+    call psb_error_handler(err_act)
+    return
+
+  End Subroutine psb_r_m_s
+
   Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb)
     use psb_error_mod
 
@@ -687,6 +724,48 @@ Contains
 
 
 
+  subroutine psb_ab_cpy_m_s(vin,vout,info) 
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    integer(psb_mpk_), allocatable, intent(in)  :: vin
+    integer(psb_mpk_), allocatable, intent(out) :: vout
+    integer(psb_ipk_) :: info
+    ! ...Local Variables
+
+    integer(psb_ipk_) :: isz,err_act,lb
+    character(len=20)  :: name, char_err
+    logical, parameter :: debug=.false.
+
+    name='psb_ab_cpy_m_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_
+    if(psb_errstatus_fatal()) then 
+      info=psb_err_from_subroutine_
+      goto 9999
+    end if
+
+    if (allocated(vin)) then 
+      call psb_realloc(vout,info)
+      if (info /= psb_success_) then     
+        info=psb_err_from_subroutine_
+        char_err='psb_realloc'
+        call psb_errpush(info,name,a_err=char_err)
+        goto 9999
+      else
+        vout = vin
+      endif
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+
+    return
+
+  end subroutine psb_ab_cpy_m_s
+
   subroutine psb_ab_cpy_m_rk1(vin,vout,info) 
     use psb_error_mod
 

base/modules/auxil/psb_s_realloc_mod.F90

@@ -39,6 +39,7 @@ module psb_s_realloc_mod
   ! the size specified, possibly shortening it. 
   !
   Interface psb_realloc
+    module procedure psb_r_s_s
     module procedure psb_r_m_s_rk1
     module procedure psb_r_m_s_rk2
     module procedure psb_r_e_s_rk1
@@ -56,7 +57,7 @@ module psb_s_realloc_mod
   end interface psb_move_alloc
 
   Interface psb_safe_ab_cpy
-    module procedure psb_ab_cpy_s_rk1, psb_ab_cpy_s_rk2
+    module procedure psb_ab_cpy_s_s, psb_ab_cpy_s_rk1, psb_ab_cpy_s_rk2
   end Interface psb_safe_ab_cpy
 
   Interface psb_safe_cpy
@@ -82,6 +83,42 @@ module psb_s_realloc_mod
 
 Contains
 
+  Subroutine psb_r_s_s(rrax,info)
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    real(psb_spk_), allocatable, intent(inout) :: rrax
+    integer(psb_ipk_) :: info
+
+    ! ...Local Variables
+    integer(psb_ipk_) :: err_act,err
+    character(len=20)  :: name
+    logical, parameter :: debug=.false.
+
+    name='psb_r_s_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_ 
+
+    if (.not.allocated(rrax)) then 
+      Allocate(rrax,stat=info)
+      if (info /= psb_success_) then
+        err=4025
+        call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
+             & a_err='real(psb_spk_)')
+        goto 9999
+      end if
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    info = err
+    call psb_error_handler(err_act)
+    return
+
+  End Subroutine psb_r_s_s
+
   Subroutine psb_r_m_s_rk1(len,rrax,info,pad,lb)
     use psb_error_mod
 
@@ -687,6 +724,48 @@ Contains
 
 
 
+  subroutine psb_ab_cpy_s_s(vin,vout,info) 
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    real(psb_spk_), allocatable, intent(in)  :: vin
+    real(psb_spk_), allocatable, intent(out) :: vout
+    integer(psb_ipk_) :: info
+    ! ...Local Variables
+
+    integer(psb_ipk_) :: isz,err_act,lb
+    character(len=20)  :: name, char_err
+    logical, parameter :: debug=.false.
+
+    name='psb_ab_cpy_s_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_
+    if(psb_errstatus_fatal()) then 
+      info=psb_err_from_subroutine_
+      goto 9999
+    end if
+
+    if (allocated(vin)) then 
+      call psb_realloc(vout,info)
+      if (info /= psb_success_) then     
+        info=psb_err_from_subroutine_
+        char_err='psb_realloc'
+        call psb_errpush(info,name,a_err=char_err)
+        goto 9999
+      else
+        vout = vin
+      endif
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+
+    return
+
+  end subroutine psb_ab_cpy_s_s
+
   subroutine psb_ab_cpy_s_rk1(vin,vout,info) 
     use psb_error_mod
 

base/modules/auxil/psb_z_realloc_mod.F90

@@ -39,6 +39,7 @@ module psb_z_realloc_mod
   ! the size specified, possibly shortening it. 
   !
   Interface psb_realloc
+    module procedure psb_r_z_s
     module procedure psb_r_m_z_rk1
     module procedure psb_r_m_z_rk2
     module procedure psb_r_e_z_rk1
@@ -56,7 +57,7 @@ module psb_z_realloc_mod
   end interface psb_move_alloc
 
   Interface psb_safe_ab_cpy
-    module procedure psb_ab_cpy_z_rk1, psb_ab_cpy_z_rk2
+    module procedure psb_ab_cpy_z_s, psb_ab_cpy_z_rk1, psb_ab_cpy_z_rk2
   end Interface psb_safe_ab_cpy
 
   Interface psb_safe_cpy
@@ -82,6 +83,42 @@ module psb_z_realloc_mod
 
 Contains
 
+  Subroutine psb_r_z_s(rrax,info)
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    complex(psb_dpk_), allocatable, intent(inout) :: rrax
+    integer(psb_ipk_) :: info
+
+    ! ...Local Variables
+    integer(psb_ipk_) :: err_act,err
+    character(len=20)  :: name
+    logical, parameter :: debug=.false.
+
+    name='psb_r_z_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_ 
+
+    if (.not.allocated(rrax)) then 
+      Allocate(rrax,stat=info)
+      if (info /= psb_success_) then
+        err=4025
+        call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
+             & a_err='complex(psb_dpk_)')
+        goto 9999
+      end if
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 continue
+    info = err
+    call psb_error_handler(err_act)
+    return
+
+  End Subroutine psb_r_z_s
+
   Subroutine psb_r_m_z_rk1(len,rrax,info,pad,lb)
     use psb_error_mod
 
@@ -687,6 +724,48 @@ Contains
 
 
 
+  subroutine psb_ab_cpy_z_s(vin,vout,info) 
+    use psb_error_mod
+
+    ! ...Subroutine Arguments  
+    complex(psb_dpk_), allocatable, intent(in)  :: vin
+    complex(psb_dpk_), allocatable, intent(out) :: vout
+    integer(psb_ipk_) :: info
+    ! ...Local Variables
+
+    integer(psb_ipk_) :: isz,err_act,lb
+    character(len=20)  :: name, char_err
+    logical, parameter :: debug=.false.
+
+    name='psb_ab_cpy_z_s'
+    call psb_erractionsave(err_act)
+    info=psb_success_
+    if(psb_errstatus_fatal()) then 
+      info=psb_err_from_subroutine_
+      goto 9999
+    end if
+
+    if (allocated(vin)) then 
+      call psb_realloc(vout,info)
+      if (info /= psb_success_) then     
+        info=psb_err_from_subroutine_
+        char_err='psb_realloc'
+        call psb_errpush(info,name,a_err=char_err)
+        goto 9999
+      else
+        vout = vin
+      endif
+    endif
+
+    call psb_erractionrestore(err_act)
+    return
+
+9999 call psb_error_handler(err_act)
+
+    return
+
+  end subroutine psb_ab_cpy_z_s
+
   subroutine psb_ab_cpy_z_rk1(vin,vout,info) 
     use psb_error_mod
 

base/modules/psb_const_mod.F90

@@ -215,8 +215,8 @@ module psb_const_mod
   ! Duplicate coefficients handling
   ! These are usually set while calling spcnv as one of its
   ! optional arugments.
-  integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 0
-  integer(psb_ipk_), parameter :: psb_dupl_add_   = 1
+  integer(psb_ipk_), parameter :: psb_dupl_add_   = 0
+  integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 1
   integer(psb_ipk_), parameter :: psb_dupl_err_   = 2
   integer(psb_ipk_), parameter :: psb_dupl_def_   = psb_dupl_add_
   ! Matrix update mode

util/Makefile

@@ -18,7 +18,7 @@ IMPLOBJS= psb_s_hbio_impl.o psb_d_hbio_impl.o \
 	psb_s_mat_dist_impl.o psb_d_mat_dist_impl.o \
 	psb_c_mat_dist_impl.o psb_z_mat_dist_impl.o \
 	psb_s_renum_impl.o psb_d_renum_impl.o \
-	psb_c_renum_impl.o psb_z_renum_impl.o
+	psb_c_renum_impl.o psb_z_renum_impl.o psi_build_mtpart.o
 
 MODOBJS=psb_util_mod.o $(BASEOBJS)
 COBJS=metis_int.o psb_amd_order.o

util/psb_metispart_mod.F90

@@ -56,7 +56,7 @@
 module psb_metispart_mod
   use psb_base_mod, only : psb_sspmat_type, psb_cspmat_type,&
        & psb_dspmat_type, psb_zspmat_type, psb_err_unit, &
-       & psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, &
+       & psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_spk_,&
        & psb_s_csr_sparse_mat, psb_d_csr_sparse_mat, &
        & psb_c_csr_sparse_mat, psb_z_csr_sparse_mat
   public part_graph, build_mtpart, distr_mtpart,&
@@ -65,12 +65,20 @@ module psb_metispart_mod
   integer(psb_ipk_), allocatable, save :: graph_vect(:)
 
   interface build_mtpart
-    module procedure build_mtpart,&
-         & d_mat_build_mtpart, s_mat_build_mtpart,&
-         & z_mat_build_mtpart, c_mat_build_mtpart, &
-         & d_csr_build_mtpart, s_csr_build_mtpart,&
-         & z_csr_build_mtpart, c_csr_build_mtpart
+    module procedure d_mat_build_mtpart, s_mat_build_mtpart,&
+         & z_mat_build_mtpart, c_mat_build_mtpart
+  end interface
+
+  interface
+    subroutine psi_build_mtpart(n,ja,irp,nparts,vect, weights)
+      import :: psb_ipk_, psb_spk_
+      implicit none 
+      integer(psb_ipk_), intent(in) :: n, nparts
+      integer(psb_ipk_), intent(in) :: ja(:), irp(:)
+      integer(psb_ipk_), allocatable, intent(inout) :: vect(:)
+      real(psb_spk_),optional, intent(in) :: weights(:)
       
+    end subroutine psi_build_mtpart
   end interface
   
 contains
@@ -180,9 +188,9 @@ contains
       end if
     end if
     if (allocated(wgh_)) then 
-      call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,wgh_)
+      call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,wgh_)
     else
-      call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts)
+      call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect)
     end if
 
   end subroutine d_csr_build_mtpart
@@ -219,9 +227,9 @@ contains
       end if
     end if
     if (allocated(wgh_)) then 
-      call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,wgh_)
+      call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,wgh_)
     else
-      call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts)
+      call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect)
     end if
 
   end subroutine z_csr_build_mtpart
@@ -268,7 +276,7 @@ contains
     real(psb_spk_), optional :: weights(:)
     
     
-    call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,weights)
+    call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,weights)
 
   end subroutine c_csr_build_mtpart
   
@@ -280,111 +288,10 @@ contains
     real(psb_spk_), optional :: weights(:)
     
 
-    call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,weights)
+    call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,weights)
 
   end subroutine s_csr_build_mtpart
 
-  subroutine build_mtpart(n,fida,ja,irp,nparts,weights)
-    use psb_base_mod
-    implicit none 
-    integer(psb_ipk_) :: nparts
-    integer(psb_ipk_) :: ja(:), irp(:)
-    integer(psb_ipk_) :: n, i,numflag,nedc,wgflag
-    character(len=5)     :: fida
-    integer(psb_ipk_), parameter :: nb=512
-    real(psb_dpk_), parameter :: seed=12345.d0
-    integer(psb_ipk_) :: iopt(10),idummy(2),jdummy(2), info
-    real(psb_spk_),optional :: weights(:)
-    integer(psb_ipk_) :: nl,nptl
-    integer(psb_ipk_), allocatable :: irpl(:),jal(:),gvl(:)
-    real(psb_spk_),allocatable  :: wgh_(:)
-
-#if defined(HAVE_METIS) && defined(IPK4)
-    interface 
-      ! subroutine METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,&
-      !     & wgflag,numflag,nparts,weights,iopt,nedc,part) bind(c)
-      !   use iso_c_binding
-      !   integer(c_int) :: n,wgflag,numflag,nparts,nedc
-      !   integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
-      !   real(c_float)  :: weights(*)
-      !   !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
-      !   !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
-      ! end subroutine METIS_PartGraphKway
-
-      function METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,&
-           & nparts,weights,part) bind(c,name="metis_PartGraphKway_C") result(res)
-        use iso_c_binding
-        integer(c_int) :: res
-        integer(c_int) :: n,nparts
-        integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),part(*)
-        real(c_float)  :: weights(*)
-        !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
-        !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
-      end function METIS_PartGraphKway
-    end interface
-
-    call psb_realloc(n,graph_vect,info)
-    if (info == psb_success_) allocate(gvl(n),wgh_(nparts),stat=info)
-
-    if (info /= psb_success_) then
-      write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: memory allocation ',&
-           & ' failure.'
-      return
-    endif
-    if (nparts > 1) then
-      if (psb_toupper(fida) == 'CSR') then 
-        iopt(1) = 0
-        numflag  = 1
-        wgflag   = 0
-
-!!$        write(*,*) 'Before allocation',nparts
-
-        irpl=irp
-        jal = ja
-        nl = n
-        nptl = nparts
-        wgh_ = -1.0
-        if(present(weights)) then
-          if (size(weights) == nptl) then 
-!!$            write(*,*) 'weights present',weights
-            ! call METIS_PartGraphKway(n,irp,ja,idummy,jdummy,&
-            !      & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect)
-            info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
-                 & nptl,weights,gvl)
-
-          else
-!!$            write(*,*) 'weights absent',wgh_
-            info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
-                 & nptl,wgh_,gvl)
-          end if
-        else
-!!$          write(*,*) 'weights absent',wgh_
-          info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
-               & nptl,wgh_,gvl)
-        endif
-!!$        write(*,*) 'after allocation',info
-
-        do i=1, n
-          graph_vect(i) = gvl(i) - 1 
-        enddo
-      else
-        write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: matrix format ',&
-             & ' failure. ', FIDA
-        return
-      endif
-    else
-      do i=1, n
-        graph_vect(i) = 0
-      enddo
-    endif
-#else
-    write(psb_err_unit,*) 'Warning: METIS was not configured at PSBLAS compile time !'
-#endif
-
-    return
-
-  end subroutine build_mtpart
-
   !
   ! WARNING: called IRET otherwise Intel compiler complains,
   ! methinks it's a compiler bug, will need to report. 

util/psi_build_mtpart.F90

@@ -0,0 +1,95 @@
+
+subroutine psi_build_mtpart(n,ja,irp,nparts,graph_vect,weights)
+  use psb_base_mod
+  use iso_c_binding
+  implicit none 
+  integer(psb_ipk_), intent(in) :: n, nparts
+  integer(psb_ipk_), intent(in) :: ja(:), irp(:)
+  integer(psb_ipk_), allocatable, intent(inout) :: graph_vect(:)
+  real(psb_spk_),optional, intent(in) :: weights(:)
+  ! local variables
+  integer(psb_ipk_) :: i,numflag, nedc,wgflag
+  integer(psb_ipk_) :: iopt(10),idummy(2),jdummy(2), info
+  integer(psb_ipk_) :: nl,nptl
+  integer(psb_ipk_), allocatable :: irpl(:),jal(:),gvl(:)
+  real(psb_spk_),allocatable  :: wgh_(:)
+
+#if defined(HAVE_METIS) && defined(IPK4)
+  interface 
+    ! subroutine METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,&
+    !     & wgflag,numflag,nparts,weights,iopt,nedc,part) bind(c)
+    !   use iso_c_binding
+    !   integer(c_int) :: n,wgflag,numflag,nparts,nedc
+    !   integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
+    !   real(c_float)  :: weights(*)
+    !   !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
+    !   !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
+    ! end subroutine METIS_PartGraphKway
+
+    function METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,&
+         & nparts,weights,part) bind(c,name="metis_PartGraphKway_C") result(res)
+      use iso_c_binding
+      integer(c_int) :: res
+      integer(c_int) :: n,nparts
+      integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),part(*)
+      real(c_float)  :: weights(*)
+      !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
+      !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
+    end function METIS_PartGraphKway
+  end interface
+
+  call psb_realloc(n,graph_vect,info)
+  if (info == psb_success_) allocate(gvl(n),wgh_(nparts),stat=info)
+
+  if (info /= psb_success_) then
+    write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: memory allocation ',&
+         & ' failure.'
+    return
+  endif
+  if (nparts > 1) then
+    iopt(1) = 0
+    numflag  = 1
+    wgflag   = 0
+
+!!$        write(*,*) 'Before allocation',nparts
+
+    irpl=irp
+    jal = ja
+    nl = n
+    nptl = nparts
+    wgh_ = -1.0
+    if(present(weights)) then
+      if (size(weights) == nptl) then 
+!!$            write(*,*) 'weights present',weights
+        ! call METIS_PartGraphKway(n,irp,ja,idummy,jdummy,&
+        !      & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect)
+        info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
+             & nptl,weights,gvl)
+
+      else
+!!$            write(*,*) 'weights absent',wgh_
+        info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
+             & nptl,wgh_,gvl)
+      end if
+    else
+!!$          write(*,*) 'weights absent',wgh_
+      info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
+           & nptl,wgh_,gvl)
+    endif
+!!$        write(*,*) 'after allocation',info
+
+    do i=1, n
+      graph_vect(i) = gvl(i) - 1 
+    enddo
+  else
+    do i=1, n
+      graph_vect(i) = 0
+    enddo
+  endif
+#else
+  write(psb_err_unit,*) 'Warning: METIS was not configured at PSBLAS compile time !'
+#endif
+
+  return
+
+end subroutine psi_build_mtpart