graph_partition_mpi.f90 5.55 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
! graph_partition_mpi.f90 --- generic graph partition method interface
!
! Copyright  (C)  2010  Thomas Jahns <jahns@dkrz.de>
!
! Version: 1.0
! Keywords: graph partitioning
! Author: Thomas Jahns <jahns@dkrz.de>
! Maintainer: Thomas Jahns <jahns@dkrz.de>
! URL: https://www.dkrz.de/redmine/projects/show/scales-ppm
!
! Redistribution and use in source and binary forms, with or without
! modification, are  permitted provided that the following conditions are
! met:
!
! Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 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.
!
! Neither the name of the DKRZ GmbH nor the names of its contributors
! may 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 COPYRIGHT OWNER
! OR 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.
!
! Commentary:
!
! This is currently only a convenient wrapper of ParMeTis, other
! heuristics are to follow later.
!
! Code:
!
45
MODULE graph_partition_mpi
46
  USE iso_c_binding, ONLY: c_int, c_float
47
  USE ppm_base, ONLY: abort_ppm
48
49
  IMPLICIT NONE
  PRIVATE
50
51
52
  INCLUDE 'mpif.h'
#include <ppm.inc>
  EXTERNAL :: parmetis_v3_partkway
53
  PUBLIC :: graph_partition_parmetis
54
CONTAINS
55
  SUBROUTINE graph_partition_parmetis(num_vertices, edge_list_lens, &
56
       edge_lists, partition_out, comm, num_partitions, &
57
58
59
60
       balance, num_vertex_weights, vertex_weights, edge_weights)
    INTEGER(ppm_idx), INTENT(in) :: num_vertices
    INTEGER(ppm_idx), INTENT(in) :: edge_list_lens(:)
    INTEGER(ppm_idx), INTENT(in) :: edge_lists(:)
61
    INTEGER(ppm_idx), INTENT(out) :: partition_out(*)
62
    INTEGER, OPTIONAL, INTENT(in) :: comm
63
    INTEGER, OPTIONAL, INTENT(in) :: num_partitions
64
    REAL(c_float), OPTIONAL, INTENT(in) :: balance(:, :)
65
66
67
68
    INTEGER, OPTIONAL, INTENT(in) :: num_vertex_weights
    INTEGER(ppm_idx), OPTIONAL, INTENT(in) :: vertex_weights(:)
    INTEGER(ppm_idx), OPTIONAL, INTENT(in) :: edge_weights(:)
    INTEGER(c_int) :: wgtflag
69
    INTEGER :: part_comm, comm_size, comm_rank, ierror, i
70
    INTEGER, ALLOCATABLE :: vtxdist(:)
71
    INTEGER(c_int) :: metis_options(0:2), edge_cut, num_parts
72
73
    INTEGER, PARAMETER :: max_msg_len=1024
    CHARACTER(len=max_msg_len) :: msg
74
75
    INTEGER(ppm_idx) :: dummy_weights(1)
    REAL(c_float) :: dummy_balance(1)
76

77
78
79
    IF (PRESENT(comm)) THEN; part_comm = comm; ELSE; part_comm = mpi_comm_world
    END IF
    CALL mpi_comm_size(part_comm, comm_size, ierror)
80
81
82
83
    IF (ierror /= MPI_SUCCESS) THEN
      CALL mpi_error_string(ierror, msg, max_msg_len, ierror)
      CALL abort_ppm(msg, __FILE__, __LINE__, comm)
    END IF
84
    CALL mpi_comm_rank(part_comm, comm_rank, ierror)
85
86
87
88
89
90
91
92
93
94
    IF (ierror /= MPI_SUCCESS) THEN
      CALL mpi_error_string(ierror, msg, max_msg_len, ierror)
      CALL abort_ppm(msg, __FILE__, __LINE__, comm)
    END IF

    ! build table of node distribution
    ALLOCATE(vtxdist(0:comm_size))

    i = INT(num_vertices)
    CALL mpi_allgather(i, 1, MPI_INTEGER, &
95
         vtxdist(1:comm_size), 1, MPI_INTEGER, part_comm, ierror)
96
97
98
99
100
101
102
103
104
105
106
107
108
109
    IF (ierror /= MPI_SUCCESS) then
      CALL mpi_error_string(ierror, msg, max_msg_len, ierror)
      CALL abort_ppm(msg, __FILE__, __LINE__, comm)
    END IF

    vtxdist(0) = 1
    vtxdist(comm_rank + 1) = i
    DO i = 1, comm_size
      vtxdist(i) = vtxdist(i) + vtxdist(i - 1)
    END DO

    wgtflag = 0
    IF (PRESENT(vertex_weights)) wgtflag = 2
    IF (PRESENT(edge_weights)) wgtflag = IOR(wgtflag, 1)
110
111
112
113
114
    IF (PRESENT(num_partitions)) THEN
      num_parts = num_partitions
    ELSE
      num_parts = comm_size
    END IF
115
    metis_options(0) = 0
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
    IF (PRESENT(balance) .AND. PRESENT(edge_weights)) THEN
      CALL parmetis_v3_partkway(vtxdist, edge_list_lens, edge_lists, &
           vertex_weights, edge_weights, wgtflag, 1, num_vertex_weights, &
           num_parts, balance, REAL(1.05, c_float), metis_options, edge_cut, &
           partition_out, part_comm)
    ELSE IF(PRESENT(balance)) THEN
      CALL parmetis_v3_partkway(vtxdist, edge_list_lens, edge_lists, &
           vertex_weights, dummy_weights, wgtflag, 1, num_vertex_weights, &
           num_parts, balance, REAL(1.05, c_float), metis_options, edge_cut, &
           partition_out, part_comm)
    ELSE ! neighter balance nor edge_weights present
      CALL parmetis_v3_partkway(vtxdist, edge_list_lens, edge_lists, &
           vertex_weights, dummy_weights, wgtflag, 1, num_vertex_weights, &
           num_parts, dummy_balance, REAL(1.05, c_float), metis_options, &
           edge_cut, partition_out, part_comm)
    END IF
132
  END SUBROUTINE graph_partition_parmetis
133
END MODULE graph_partition_mpi
134
135
136
137
138
!
! Local Variables:
! license-project-url: "https://www.dkrz.de/redmine/projects/show/scales-ppm"
! license-default: "bsd"
! End: