fesom2/src/mpi_topology_module.F90 at main · FESOM/fesom2 · GitHub

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
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
module hostname_sys_module
  contains

  subroutine hostname_sys(hostname)
    character(len=:), allocatable, intent(out) :: hostname
    integer*4 status, hostnm

    allocate(character(32) :: hostname) ! platform dependent length in limits.h or call `getconf HOST_NAME_MAX`
    status = hostnm(hostname)
  end subroutine hostname_sys
end module hostname_sys_module


module mpi_topology_module
! synopsis:
! collectively call mpi_topology%next_host_head_rank to get the first mpi rank of the next compute node (host) within the given communicator
! after all hosts have been used up, we will start over at the first host and increment the rank by 1
! after all ranks have been used up, we will start over at the first host with rank 0
! optional second argument will return the number of times this rank has been returned

  use hostname_sys_module
  implicit none
  public mpi_topology
  private

  type :: mpi_topology_type
  contains
    procedure, nopass :: next_host_head_rank
    procedure, nopass :: set_hostname_strategy
    procedure, nopass :: reset_state
  end type mpi_topology_type
  type(mpi_topology_type) mpi_topology

  logical, save :: IS_STATE_INITIALIZED = .false.

  integer, save :: MAXRANK
  integer, save :: STEP
  integer, save :: count
  integer, save :: lap
  integer, save :: host_use_count
  integer, save :: COMM
  procedure(hostname_interface), pointer, save :: hostname_strategy
  abstract interface
    subroutine hostname_interface(hostname)
    character(len=:), allocatable, intent(out) :: hostname
    end subroutine hostname_interface
  end interface

contains

  subroutine reset_state()
    MAXRANK = 0
    STEP = 0
    count = 0
    lap = 1
    host_use_count = lap
    COMM = -1
    hostname_strategy => hostname_sys

    IS_STATE_INITIALIZED = .true.
  end subroutine reset_state


  subroutine set_hostname_strategy(strategy)
    procedure(hostname_interface) strategy
    hostname_strategy => strategy
  end subroutine set_hostname_strategy


  integer recursive function next_host_head_rank(communicator, rank_use_count) result(result)
    integer, intent(in) :: communicator
    integer, optional, intent(out) :: rank_use_count

    if(.not. IS_STATE_INITIALIZED) call reset_state()
    if(communicator .ne. COMM) COMM = learn_topology(communicator)

    result = count*STEP + lap-1
    if(result > MAXRANK) then ! start a new lap
      count = 0
      host_use_count = host_use_count + 1
      lap = lap + 1
      if(lap > STEP) lap = 1 ! start over with the first rank on a host
      result = next_host_head_rank(communicator)
    else
      count = count + 1
    end if

    if(present(rank_use_count)) then
      rank_use_count = (host_use_count-1)/STEP +1
    end if
  end function next_host_head_rank


  integer function learn_topology(communicator) result(result)
    use mpi ! should prefer mpi_f08, but it is not available on some older mpi installations
    integer rank, rank_count
    integer ierror
    character(len=:), allocatable :: hostname
    character(len=:), allocatable :: names(:)
    integer i
    integer ranks_per_host
    integer, intent(in) :: communicator

    count = 0
    result = communicator

    call MPI_COMM_RANK(communicator, rank, ierror)
    call MPI_COMM_SIZE(communicator, rank_count, ierror)
    MAXRANK = rank_count-1

    call hostname_strategy(hostname)
    if(rank==0) then
      allocate(character(len(hostname)) :: names(rank_count))
    else
      allocate(character(0) :: names(0))
    end if
    call MPI_GATHER(hostname, len(hostname), MPI_CHAR, names, len(hostname), MPI_CHAR, 0, communicator, ierror)
    if(rank==0) then
        ranks_per_host = 1
        do i=1+1, size(names)
          if(hostname == names(i)) then
            ranks_per_host = ranks_per_host+1
          else
            exit
          end if
        end do
    end if
    deallocate(names)

    call MPI_BCAST(ranks_per_host, 1, MPI_INT, 0, communicator, ierror)
    STEP = ranks_per_host
  end function learn_topology
end module mpi_topology_module