You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
psblas3/util/psb_metispart_mod.F90

311 lines
9.8 KiB
Fortran

!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! 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 PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS 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.
!
!
!
! Purpose:
! Provide a set of subroutines to define a data distribution based on
! a graph partitioning routine from METIS. May serve as the basis
! for interfacing other graph partitioning tools.
!
! Subroutines:
!
! BUILD_MTPART(A,NPARTS): This subroutine will be called by the root
! process to build define the data distribuition mapping.
! Input parameters:
! TYPE(D_SPMAT) :: A The input matrix. The coefficients are
! ignored; only the structure is used.
! integer(psb_ipk_) :: NPARTS How many parts we are requiring to the
! partition utility
!
! DISTR_MTPART(ROOT,ICTXT): This subroutine will be called by
! all processes to distribute the information computed by the root
! process, to be used subsequently.
!
!
! PART_GRAPH : The subroutine to be passed to PSBLAS sparse library;
! uses information prepared by the previous two subroutines.
!
module psb_metispart_mod
use psb_base_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, &
& psb_err_unit, psb_spk_,&
& psb_lsspmat_type, psb_lcspmat_type,&
& psb_ldspmat_type, psb_lzspmat_type, &
& psb_ls_csr_sparse_mat, psb_ld_csr_sparse_mat, &
& psb_lc_csr_sparse_mat, psb_lz_csr_sparse_mat
public part_graph, build_mtpart, distr_mtpart,&
& getv_mtpart, free_part
private
integer(psb_lpk_), allocatable, save :: graph_vect(:)
interface build_mtpart
module procedure ld_mat_build_mtpart, ls_mat_build_mtpart,&
& lz_mat_build_mtpart, lc_mat_build_mtpart
end interface
interface psi_build_mtpart
subroutine psi_l_build_mtpart(n,ja,irp,nparts,vect, weights)
import :: psb_lpk_, psb_spk_
implicit none
integer(psb_lpk_), intent(in) :: n, nparts
integer(psb_lpk_), intent(in) :: ja(:), irp(:)
integer(psb_lpk_), allocatable, intent(inout) :: vect(:)
real(psb_spk_),optional, intent(in) :: weights(:)
end subroutine psi_l_build_mtpart
end interface
contains
subroutine part_graph(global_indx,n,np,pv,nv)
implicit none
integer(psb_lpk_), intent(in) :: global_indx, n
integer(psb_ipk_), intent(in) :: np
integer(psb_ipk_), intent(out) :: nv
integer(psb_ipk_), intent(out) :: pv(*)
IF (.not.allocated(graph_vect)) then
write(psb_err_unit,*) 'Fatal error in PART_GRAPH: vector GRAPH_VECT ',&
& 'not initialized'
return
endif
if ((global_indx<1).or.(global_indx > size(graph_vect))) then
write(psb_err_unit,*) 'Fatal error in PART_GRAPH: index GLOBAL_INDX ',&
& 'outside GRAPH_VECT bounds',global_indx,size(graph_vect)
return
endif
nv = 1
pv(nv) = graph_vect(global_indx)
return
end subroutine part_graph
subroutine distr_mtpart(root, ictxt)
use psb_base_mod
implicit none
integer(psb_ipk_) :: root, ictxt
integer(psb_ipk_) :: me, np, info
integer(psb_lpk_) :: n
call psb_info(ictxt,me,np)
if (.not.((root>=0).and.(root<np))) then
write(psb_err_unit,*) 'Fatal error in DISTR_MTPART: invalid ROOT ',&
& 'coordinates '
call psb_abort(ictxt)
return
endif
if (me == root) then
if (.not.allocated(graph_vect)) then
write(psb_err_unit,*) 'Fatal error in DISTR_MTPART: vector GRAPH_VECT ',&
& 'not initialized'
call psb_abort(ictxt)
return
endif
n = size(graph_vect)
call psb_bcast(ictxt,n,root=root)
else
call psb_bcast(ictxt,n,root=root)
allocate(graph_vect(n),stat=info)
if (info /= psb_success_) then
write(psb_err_unit,*) 'Fatal error in DISTR_MTPART: memory allocation ',&
& ' failure.'
return
endif
endif
call psb_bcast(ictxt,graph_vect(1:n),root=root)
return
end subroutine distr_mtpart
subroutine getv_mtpart(ivg)
implicit none
integer(psb_ipk_), allocatable, intent(out) :: ivg(:)
if (allocated(graph_vect)) then
allocate(ivg(size(graph_vect)))
ivg(:) = graph_vect(:)
end if
end subroutine getv_mtpart
subroutine ld_mat_build_mtpart(a,nparts,weights)
use psb_base_mod
implicit none
type(psb_ldspmat_type), intent(in) :: a
integer(psb_lpk_) :: nparts
real(psb_dpk_), optional :: weights(:)
select type (aa=>a%a)
type is (psb_ld_csr_sparse_mat)
call ld_csr_build_mtpart(aa,nparts,weights)
class default
write(psb_err_unit,*) 'Sorry, right now we only take CSR input!'
end select
end subroutine ld_mat_build_mtpart
subroutine ld_csr_build_mtpart(a,nparts,weights)
use psb_base_mod
implicit none
type(psb_ld_csr_sparse_mat), intent(in) :: a
integer(psb_lpk_) :: nparts
real(psb_dpk_), optional :: weights(:)
real(psb_spk_), allocatable :: wgh_(:)
if (present(weights)) then
if (size(weights)==nparts) then
wgh_ = weights
end if
end if
if (allocated(wgh_)) then
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,wgh_)
else
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect)
end if
end subroutine ld_csr_build_mtpart
subroutine lz_mat_build_mtpart(a,nparts,weights)
use psb_base_mod
implicit none
type(psb_lzspmat_type), intent(in) :: a
integer(psb_lpk_) :: nparts
real(psb_dpk_), optional :: weights(:)
select type (aa=>a%a)
type is (psb_lz_csr_sparse_mat)
call lz_csr_build_mtpart(aa,nparts,weights)
class default
write(psb_err_unit,*) 'Sorry, right now we only take CSR input!'
end select
end subroutine lz_mat_build_mtpart
subroutine lz_csr_build_mtpart(a,nparts,weights)
use psb_base_mod
implicit none
type(psb_lz_csr_sparse_mat), intent(in) :: a
integer(psb_lpk_) :: nparts
real(psb_dpk_), optional :: weights(:)
real(psb_spk_), allocatable :: wgh_(:)
if (present(weights)) then
if (size(weights)==nparts) then
wgh_ = weights
end if
end if
if (allocated(wgh_)) then
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,wgh_)
else
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect)
end if
end subroutine lz_csr_build_mtpart
subroutine ls_mat_build_mtpart(a,nparts,weights)
use psb_base_mod
implicit none
type(psb_lsspmat_type), intent(in) :: a
integer(psb_lpk_) :: nparts
real(psb_spk_), optional :: weights(:)
select type (aa=>a%a)
type is (psb_ls_csr_sparse_mat)
call ls_csr_build_mtpart(aa,nparts,weights)
class default
write(psb_err_unit,*) 'Sorry, right now we only take CSR input!'
end select
end subroutine ls_mat_build_mtpart
subroutine lc_mat_build_mtpart(a,nparts,weights)
use psb_base_mod
implicit none
type(psb_lcspmat_type), intent(in) :: a
integer(psb_lpk_) :: nparts
real(psb_spk_), optional :: weights(:)
select type (aa=>a%a)
type is (psb_lc_csr_sparse_mat)
call lc_csr_build_mtpart(aa,nparts,weights)
class default
write(psb_err_unit,*) 'Sorry, right now we only take CSR input!'
end select
end subroutine lc_mat_build_mtpart
subroutine lc_csr_build_mtpart(a,nparts,weights)
use psb_base_mod
implicit none
type(psb_lc_csr_sparse_mat), intent(in) :: a
integer(psb_lpk_) :: nparts
real(psb_spk_), optional :: weights(:)
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,weights)
end subroutine lc_csr_build_mtpart
subroutine ls_csr_build_mtpart(a,nparts,weights)
use psb_base_mod
implicit none
type(psb_ls_csr_sparse_mat), intent(in) :: a
integer(psb_lpk_) :: nparts
real(psb_spk_), optional :: weights(:)
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,weights)
end subroutine ls_csr_build_mtpart
!
! WARNING: called IRET otherwise Intel compiler complains,
! methinks it's a compiler bug, will need to report.
!
subroutine free_part(iret)
implicit none
integer(psb_ipk_), intent(out) :: iret
deallocate(graph_vect,stat=iret)
return
end subroutine free_part
end module psb_metispart_mod