Merge branch 'unify_aggr_bld' into development

pizdaint-runs
Salvatore Filippone 5 years ago
commit 78f42c8e22

@ -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

@ -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

@ -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

@ -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

@ -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

@ -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

@ -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

@ -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

@ -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

@ -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,18 +65,26 @@ 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
subroutine part_graph(global_indx,n,np,pv,nv)
implicit none
implicit none
integer(psb_lpk_), intent(in) :: global_indx, n
integer(psb_ipk_), intent(in) :: np
integer(psb_ipk_), intent(out) :: nv
@ -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.

@ -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
Loading…
Cancel
Save