DISPATCH
mpi_mod.f90
1 !===============================================================================
2 !> $Id: a35de29b50d29cead00bbb68266e199dd78e3c86 $
3 !> Basic MPI calls; initialization, end, barriers, asserts, wallclock, ...
4 !>
5 !> To make use of this module, make sure it is compiled together with your code,
6 !> using either the Makefile and the 'make' command, or compiling manually, with
7 !>
8 !> mpi = ../../../../../mpi # or wherever
9 !> mpifort -c $mpi/mpi_mod.f90 # compiler mpi_mod.f90
10 !> mpifort -c $mpi/mpi_... # add any other module your need
11 !> mpifort -c your_code.f90 # compile your code
12 !> mpifort *.o -o your_code.x # link together into your_code.x
13 !>
14 !> In your_code.f90 you add lines such as:
15 !>
16 !> USE mpi_mod ! makes the mpi% object available
17 !> ...
18 !> call mpi%init ! initializes the mpi%object
19 !> ...
20 !> if (mpi%rank==0) print *, 'this will be printed only on MPI process 0'
21 !> ...
22 !> call mpi%end ! closes MPI
23 !>
24 !> Too see which variables and procedures are inside mpi%, just look below!
25 !>
26 !===============================================================================
27 MODULE mpi_mod
28  USE omp_mod
29  USE omp_timer_mod
30  USE io_unit_mod
31  implicit none
32  private
33 #ifdef MPI
34  include 'mpif.h' ! some systems require this instead of 'use mpi'
35 #endif
36  integer:: mpi_err ! MPI error status
37  logical:: mpi_master ! true on MPI master (rank 0)
38  logical:: mpi_trace=.false. ! debug trace option
39  logical:: master=.true. ! true on OMP master thread on MPI master process
40  integer:: mpi_size ! number of MPI processes
41  integer:: mpi_rank ! process number (zero-based)
42  integer:: output=2
43  logical:: first_time = .true.
44  !-----------------------------------------------------------------------------
45  ! Object that support atomic incremental counting across MPI ranks. The
46  ! counter value %v reflects the actual counter value, but only at the very
47  ! moment when it was upated, not at the moment when it happens to be accessed.
48  !-----------------------------------------------------------------------------
49  type, public:: mpi_counter_t
50  integer:: window
51  integer(8):: i=0 ! shared window value
52  integer(8):: value=0 ! actual counter value, after update
53  contains
54  procedure, private:: init4
55  procedure, private:: init8
56  generic:: init => init4, init8
57  procedure, private:: reset4
58  procedure, private:: reset8
59  generic:: reset => reset4, reset8
60  procedure, private:: update4
61  procedure, private:: update8
62  generic:: update => update4, update8
63  end type
64  !-----------------------------------------------------------------------------
65  ! Object that contains the most important MPI parameters
66  !-----------------------------------------------------------------------------
67  type, public:: mpi_t
68  integer:: size=1, rank=0, comm, verbose=0
69  integer:: mode
70  logical:: master
71  logical:: ok = .false.
72  type(mpi_counter_t):: id, file_size
73  contains
74  procedure:: init
75  procedure:: barrier => barrier_
76  procedure:: print => print_
77  procedure:: assert
78  procedure:: abort => abort_mpi
79  procedure:: end => end_mpi
80  procedure, nopass:: delay
81  end type
82  type(mpi_t), public:: mpi
83 CONTAINS
84 
85 !===============================================================================
86 !> Initialize an object with the most important pieces of information about MPI:
87 !> mpi%size = the number of MPI ranks
88 !> mpi%rank = the rank of the current MPI process (0-indexed)
89 !> mpi%coord = the 3-D position of the rank, if a Cartesian arrangement is used
90 !===============================================================================
91 SUBROUTINE init (self, mpi_dims, dims)
92  class(mpi_t):: self
93  integer, optional, dimension(3):: mpi_dims, dims
94  real(8):: offset
95  character(len=120):: ids = &
96  '$Id: a35de29b50d29cead00bbb68266e199dd78e3c86 $ mpi/mpi_mod.f90'
97  !-----------------------------------------------------------------------------
98  if (self%ok) return
99  if (first_time) then
100  first_time = .false.
101  call init_mpi (self)
102  call omp%init
103  call detect_cores
104 #ifdef MPI
105  call mpi_bcast (omp%ncores, 1, mpi_integer, 0, self%comm, mpi_err)
106  call omp_timer%get (offset)
107  call mpi_bcast (offset, 1, mpi_real8, 0, self%comm, mpi_err)
108  call omp_timer%set (offset)
109 #endif
110  end if
111 #ifdef MPI
112  mpi%size = mpi_size
113  mpi%rank = mpi_rank
114  mpi%master = mpi_rank==0
115 #else
116  mpi%size = 1
117  mpi%rank = 0
118  mpi%comm = 0
119  mpi%master = (mpi_rank==0)
120 #endif
121  mpi%ok = .true.
122  if (mpi%master .and. first_time) &
123  print'(1x,a)', trim(ids)
124  !-----------------------------------------------------------------------------
125  ! For some reason, this must be done element by element. Turning it around,
126  ! and doing mpi = self (which is syntactically correct), values are screwed
127  !-----------------------------------------------------------------------------
128  self%size = mpi%size
129  self%rank = mpi%rank
130  self%comm = mpi%comm
131  self%master = mpi%master
132  self%ok = mpi%ok
133  !-----------------------------------------------------------------------------
134  call mpi%id%init (1)
135  call mpi%file_size%init (0_8)
136  !-----------------------------------------------------------------------------
137  ! Make sure output from startup is finished
138  !-----------------------------------------------------------------------------
139  flush (io_unit%output)
140  call self%barrier (delay=0.1)
141 END SUBROUTINE init
142 
143 !===============================================================================
144 !===============================================================================
145 SUBROUTINE print_ (self)
146  class(mpi_t):: self
147  if (master) print *, 'mpi%size =', mpi%size
148 END SUBROUTINE
149 !===============================================================================
150 !> MPI barrier with optional label and delay -- often necessary to arrange serial
151 !> printout from all ranks, one at a time
152 !===============================================================================
153 SUBROUTINE barrier_ (self, label, delay)
154  class(mpi_t):: self
155  character(len=*), optional:: label
156  real, optional:: delay
157  integer:: i
158  real(8):: wc
159  !.............................................................................
160  if (.not.self%ok) return
161  if (present(delay)) then
162  wc = wallclock()
163  do while (wallclock()-wc < delay)
164  end do
165  end if
166  if (present(label)) then
167  call barrier_mpi (self, label)
168  else
169  call barrier_mpi (self, 'mpi%barrier')
170  end if
171 END SUBROUTINE barrier_
172 
173 !===============================================================================
174 SUBROUTINE init_mpi (self)
175  implicit none
176  class(mpi_t):: self
177  character(len=mch):: id='mpi.f90 $Id: a35de29b50d29cead00bbb68266e199dd78e3c86 $'
178  character(len=mch):: filename
179  integer:: mpi_provided
180 !-------------------------------------------------------------------------------
181 ! Start up MPI and get number of nodes and our node rank
182 !-------------------------------------------------------------------------------
183 #ifdef MPI
184 #ifdef __GFORTRAN__
185  call mpi_init_thread (mpi_thread_single, mpi_provided, mpi_err)
186 #else
187  call mpi_init_thread (mpi_thread_multiple, mpi_provided, mpi_err)
188 #endif
189  self%mode = mpi_provided
190  call mpi_comm_dup (mpi_comm_world, self%comm, mpi_err)
191  call mpi_comm_size (self%comm, mpi_size, mpi_err)
192  call mpi_comm_rank (self%comm, mpi_rank, mpi_err)
193  mpi_master = (mpi_rank == 0)
194  master = mpi_master
195  if (master) then
196  print 1, '--------------------------------------------------------------------------------'
197  !!!print 1, ' '//id
198  print 1, ' MPI initialized, mpi%size =', mpi_size
199  1 format(a,i7)
200  select case (mpi_provided)
201  case(mpi_thread_multiple)
202  print 1, ' MPI implementation provides support for simultaneous MPI calls by different threads'
203  case(mpi_thread_single)
204  print 1, ' MPI implementation only provides support for MPI calls in one thread at a time'
205  case(mpi_thread_funneled)
206  print 1, ' MPI implementation only provides support for MPI calls in master regions'
207  case(mpi_thread_serialized)
208  print 1, ' MPI implementation only provides support for serial MPI calls by any thread'
209  case default
210  print 1, ' unknown MPI implementation'
211  end select
212  print 1, '--------------------------------------------------------------------------------'
213  end if
214  if (self%verbose > 1) then
215  write (filename,'(a,i4.4,a)') 'rank_', mpi_rank, '.dat'
216  open (output, file=filename, form='formatted', status='unknown')
217  end if
218 #else
219  mpi_rank = 0
220  mpi_master = (mpi_rank == 0)
221  master = mpi_master
222  print*,'MPI is not enabled!'
223 #endif
224 END SUBROUTINE init_mpi
225 
226 !===============================================================================
227 SUBROUTINE end_mpi (self, label)
228  class(mpi_t):: self
229  character(len=*), optional:: label
230 !..............................................................................
231  !call finalize_cart
232  if (mpi_rank==0) then
233  if (present(label)) then
234  print*,'MPI finalized with message: "'//trim(label)//'"'
235  end if
236  end if
237 #ifdef MPI
238  write (io_unit%mpi,*) self%rank, wallclock(), 'calling MPI_Finalize'
239  flush (io_unit%mpi)
240  call mpi_finalize (mpi_err)
241  write (io_unit%mpi,*) self%rank, wallclock(), 'returned from MPI_Finalize'
242  flush (io_unit%mpi)
243 #endif
244  !call exit ! avoid "stop" which may produce one output line per process
245 END SUBROUTINE
246 
247 !===============================================================================
248 SUBROUTINE abort_mpi (self, reason)
249  class(mpi_t):: self
250  character(len=*), optional:: reason
251 !...............................................................................
252 #ifdef MPI
253  !-----------------------------------------------------------------------------
254  ! Give other ranks a chance to issue messages as well, then abort
255  !-----------------------------------------------------------------------------
256  flush (io_unit%output)
257  call message (stderr)
258  call message (io_unit%log)
259  call delay (3e3)
260  call mpi_abort (mpi_comm_world, 127, mpi_err)
261 #endif
262  call exit
263 contains
264  subroutine message (unit)
265  integer:: unit
266  flush (unit)
267  if (present(reason)) then
268  write (unit,'("ABORT: rank",i5,4x,"thread",i4,4x,"reason: ",a)') &
269  mpi_rank, omp%thread, trim(reason)
270  else
271  write (unit,'("ABORT: rank",i5,4x,"thread",i4,4x,"generic")') &
272  mpi_rank, omp%thread
273  end if
274  flush (unit)
275  end subroutine
276 END SUBROUTINE abort_mpi
277 
278 !===============================================================================
279 SUBROUTINE clean_stop
280 !...............................................................................
281 #ifdef MPI
282  call mpi_abort (mpi_comm_world, 127, mpi_err)
283 #endif
284  call exit
285 END SUBROUTINE clean_stop
286 
287 !===============================================================================
288 SUBROUTINE barrier_mpi (self, label)
289  class(mpi_t):: self
290  character(len=*) label
291 !...............................................................................
292  if (mpi_trace) print *, mpi_rank, 'barrier_mpi: '//label
293  if (self%verbose > 2) then
294  write (output,*) mpi_rank, 'barrier_mpi: '//label
295  flush (output)
296  end if
297 #ifdef MPI
298  call mpi_barrier (mpi_comm_world, mpi_err)
299 #endif
300 END SUBROUTINE barrier_mpi
301 
302 !===============================================================================
303 SUBROUTINE assert (self, message, code)
304  class(mpi_t):: self
305  character(len=*):: message
306  integer code
307  character (len=16):: codemsg
308 !..............................................................................
309  if (code/=0) then
310  write (codemsg,'("code =",i10)') code
311  write(*,*) mpi_rank,' error: '//trim(message)
312  if (self%verbose > 1) then
313  write(output,*) mpi_rank,' error: '//trim(message)
314  flush (output)
315  end if
316  end if
317 END SUBROUTINE assert
318 
319 !===============================================================================
320 !> Attempt to determine the actual number of cores. If /proc/cpuinfo exists
321 !> one has to count the number of sockets, but observing hom many different
322 !> "physical id" there are. The number of cores per socket is in the field
323 !> "cpu cores".
324 !===============================================================================
325 SUBROUTINE detect_cores
326  character(len=32):: file="/proc/cpuinfo"
327  character(len=32):: line
328  logical:: exist
329  integer:: i, iostat, id, oid, n_socket, n_core
330  type:: socket_t
331  type(socket_t), pointer:: next => null()
332  integer:: id
333  end type
334  type(socket_t), pointer:: p, o, head
335  real(8):: wc
336  !.............................................................................
337  nullify(head)
338  n_socket = 0
339  oid = -1
340  inquire (file=file, exist=exist)
341  if (exist) then
342  wc = wallclock()
343  open (file=file, unit=io_unit%os, form='formatted', status='old')
344  do while (.true.)
345  read (io_unit%os,'(a32)',iostat=iostat) line
346  if (iostat/=0) then
347  exit
348  else
349  i = index(line,':')
350  if (line(1:8)=='cpu core') then
351  read (line(i+1:),*) n_core
352  else if (line(1:8)=='physical') then
353  read (line(i+1:),*) id
354  if (new(id)) then
355  n_socket = n_socket + 1
356  end if
357  end if
358  end if
359  end do
360  close (io_unit%os)
361  wc = wallclock()-wc
362  if (wc > 5) print '(a)','############################################################'
363  if (mpi%master) &
364  print '(a,f6.1,a)', 'reading /proc/cpuinfo:', wc, ' sec'
365  if (wc > 5) print '(a)','############################################################'
366  end if
367  if (n_socket>0) n_core = n_core*n_socket
368  !$omp parallel
369  omp%ncores = n_core
370  !$omp end parallel
371 !-----------------------------------------------------------------------------
372 ! For good measure, although totally insignificant, deallocate the list
373 !-----------------------------------------------------------------------------
374  p => head
375  do while (associated(p))
376  o => p
377  p => p%next
378  deallocate (o)
379  end do
380 CONTAINS
381  logical function new(id)
382  integer:: id
383  p => head
384  o => p
385 !---------------------------------------------------------------------------
386 ! If the id already exists, return false
387 !---------------------------------------------------------------------------
388  do while (associated(p))
389  o => p
390  if (p%id == id) then
391  new = .false.
392  return
393  end if
394  p => p%next
395  end do
396 !---------------------------------------------------------------------------
397 ! If the id did not exist, add it, and return true
398 !---------------------------------------------------------------------------
399  allocate (p)
400  p%id = id
401  if (associated(o)) then
402  o%next => p
403  else
404  head => p
405  end if
406  new = .true.
407  end function
408 END SUBROUTINE detect_cores
409 
410 !===============================================================================
411 !> Delay for about 1 ms, to encourage incoming messages to complete
412 !===============================================================================
413 SUBROUTINE delay (ms)
414  real:: ms
415  real(8):: wc
416  !-----------------------------------------------------------------------------
417  wc = wallclock()
418  do while ((wallclock()-wc) < 1e-3*ms)
419  end do
420 END SUBROUTINE delay
421 
422 !===============================================================================
423 !> Create and initialize a counter to value = n. NOTE: This is COLLECTIVE call!
424 !===============================================================================
425 SUBROUTINE init4 (self, n)
426  class(mpi_counter_t):: self
427  integer:: n
428  !.............................................................................
429 #ifdef MPI
430  integer(kind=MPI_ADDRESS_KIND):: nbytes=8
431  integer:: mpi_err
432  !----------------------------------------------------------------------------
433  self%i = n
434  call mpi_win_create (self%i, nbytes, 8, mpi_info_null, mpi_comm_world, &
435  self%window, mpi_err)
436  call mpi%assert ('MPI_Win_create', mpi_err)
437 #endif
438 END SUBROUTINE init4
439 
440 !===============================================================================
441 !> Create and initialize a counter to value = n. NOTE: This is COLLECTIVE call!
442 !===============================================================================
443 SUBROUTINE init8 (self, n)
444  class(mpi_counter_t):: self
445  integer(8):: n
446  !.............................................................................
447 #ifdef MPI
448  integer(kind=MPI_ADDRESS_KIND):: nbytes=8
449  integer:: mpi_err
450  !----------------------------------------------------------------------------
451  self%i = n
452  call mpi_win_create (self%i, nbytes, 8, mpi_info_null, mpi_comm_world, &
453  self%window, mpi_err)
454  call mpi%assert ('MPI_Win_create', mpi_err)
455 #endif
456 END SUBROUTINE init8
457 
458 !===============================================================================
459 !> Reset the counter to n
460 !===============================================================================
461 SUBROUTINE reset4 (self, n)
462  class(mpi_counter_t):: self
463  integer:: n, i
464  !.............................................................................
465  i = self%update(0)
466  i = self%update(n-i)
467 END SUBROUTINE reset4
468 
469 !===============================================================================
470 !> Reset the counter to n
471 !===============================================================================
472 SUBROUTINE reset8 (self, n)
473  class(mpi_counter_t):: self
474  integer(8):: n, i
475  !.............................................................................
476  i = self%update(0_8)
477  i = self%update(n-i)
478 END SUBROUTINE reset8
479 
480 !===============================================================================
481 !> Add a value i to the counter on master. If the value reaches 0, return 0,
482 !> while resetting the counter to n. Allow both 4-byte and 8-byte arguments.
483 !===============================================================================
484 FUNCTION update4 (self, i, n) RESULT (j)
485  class(mpi_counter_t):: self
486  integer:: i, j
487  integer, optional:: n
488  !.............................................................................
489  if (present(n)) then
490  j= update8(self, int(i,kind=8), int(n,kind=8))
491  else
492  j= update8(self, int(i,kind=8))
493  end if
494 END FUNCTION update4
495 !===============================================================================
496 FUNCTION update8 (self, i, n) RESULT (j)
497  class(mpi_counter_t):: self
498  integer(8):: i, j
499  integer(8), optional:: n
500  !.............................................................................
501  integer:: master=0, mpi_err
502 #ifdef MPI
503  integer(kind=MPI_ADDRESS_KIND):: offset=0
504  !-----------------------------------------------------------------------------
505  if (io_unit%verbose > 0) &
506  write (io_unit%log,'(a,2(2x,3i4))') &
507  'mpi_counter_t%update(1): incr, sum, rank, size =', &
508  i, self%i, mpi%rank, mpi%size
509  if (mpi%mode == mpi_thread_multiple) then
510  call accumulate (i)
511  else
512  !$omp critical (mpi_cr)
513  call accumulate (i)
514  !$omp end critical (mpi_cr)
515  end if
516  !$omp atomic write
517  self%value = j + i
518  if (i+j==0) then
519  if (present(n)) then
520  self%i = n
521  end if
522  end if
523  return
524 contains
525  !-----------------------------------------------------------------------------
526  subroutine accumulate (i)
527  integer(8):: i
528  !$omp critical (mpi_win_cr)
529  call mpi_win_lock (mpi_lock_exclusive, master, 0, self%window, mpi_err)
530  call add(i)
531  call mpi_win_flush (master, self%window, mpi_err)
532  !-----------------------------------------------------------------------------
533  ! The window value is incremented by "i", but the return value "j" reflects
534  ! the value of the window variable BEFORE the update, and this is what the
535  ! exposed value %i should reflect, on all ranks
536  !-----------------------------------------------------------------------------
537  if (io_unit%verbose > 0) &
538  write (io_unit%log,'(a,2(2x,3i4))') &
539  'mpi_counter_t%update(2): val, sum, rank, size =', &
540  j, self%i, mpi%rank, mpi%size
541  call mpi_win_unlock (master, self%window, mpi_err)
542  !$omp end critical (mpi_win_cr)
543  end subroutine accumulate
544  !-----------------------------------------------------------------------------
545  ! The MPI call returns, in the j argument, the value of the counter in the
546  ! window, BEFORE the update.
547  !-----------------------------------------------------------------------------
548  subroutine add (i)
549  integer(8):: i
550  call mpi_get_accumulate (i, 1, mpi_integer8, &
551  j, 1, mpi_integer8, master, offset, &
552  1, mpi_integer8, mpi_sum, self%window, mpi_err)
553  call mpi%assert ('MPI_Accumulate', mpi_err)
554  end subroutine add
555 #else
556  !$omp atomic capture
557  j = self%i
558  self%i = self%i + i
559  !$omp end atomic
560 #endif
561 END FUNCTION update8
562 
563 END MODULE mpi_mod
564 
565 !===============================================================================
566 !> Enable copying between any 4-byte arrays, without type checking restrictions
567 !===============================================================================
568 SUBROUTINE anonymous_copy (n, a, b)
569  integer:: n
570  real(4):: a(n), b(n)
571  b = a
572 END SUBROUTINE anonymous_copy
Support tic/toc timing, as in MATLAB, and accurate wallclock() function. The timing is generally much...