PartMC  2.3.0
mpi.F90
Go to the documentation of this file.
1 ! Copyright (C) 2007-2015 Matthew West
2 ! Licensed under the GNU General Public License version 2 or (at your
3 ! option) any later version. See the file COPYING for details.
4 
5 !> \file
6 !> The pmc_mpi module.
7 
8 !> Wrapper functions for MPI.
9 !!
10 !! All of these functions can be called irrespective of whether MPI
11 !! support was compiled in or not. If MPI support is not enabled then
12 !! they do the obvious trivial thing (normally nothing).
13 module pmc_mpi
14 
15  use pmc_util
16 
17 #ifdef PMC_USE_MPI
18  use mpi
19 #endif
20 
21 contains
22 
23 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
24 
25  !> Whether MPI support is compiled in.
26  logical function pmc_mpi_support()
27 
28 #ifdef PMC_USE_MPI
29  pmc_mpi_support = .true.
30 #else
31  pmc_mpi_support = .false.
32 #endif
33 
34  end function pmc_mpi_support
35 
36 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
37 
38  !> Dies if \c ierr is not ok.
39  subroutine pmc_mpi_check_ierr(ierr)
40 
41  !> MPI status code.
42  integer, intent(in) :: ierr
43 
44 #ifdef PMC_USE_MPI
45  if (ierr /= mpi_success) then
46  call pmc_mpi_abort(1)
47  end if
48 #endif
49 
50  end subroutine pmc_mpi_check_ierr
51 
52 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
53 
54  !> Initialize MPI.
55  subroutine pmc_mpi_init()
56 
57 #ifdef PMC_USE_MPI
58  integer :: ierr
59 
60  call mpi_init(ierr)
61  call pmc_mpi_check_ierr(ierr)
62  call pmc_mpi_test()
63 #endif
64 
65  end subroutine pmc_mpi_init
66 
67 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
68 
69  !> Abort the program.
70  subroutine pmc_mpi_abort(status)
71 
72  !> Status flag to abort with.
73  integer, intent(in) :: status
74 
75 #ifdef PMC_USE_MPI
76  integer :: ierr
77 
78  call mpi_abort(mpi_comm_world, status, ierr)
79 #else
80  call die(status)
81 #endif
82 
83  end subroutine pmc_mpi_abort
84 
85 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
86 
87  !> Shut down MPI.
88  subroutine pmc_mpi_finalize()
89 
90 #ifdef PMC_USE_MPI
91  integer :: ierr
92 
93  call mpi_finalize(ierr)
94  call pmc_mpi_check_ierr(ierr)
95 #endif
96 
97  end subroutine pmc_mpi_finalize
98 
99 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
100 
101  !> Synchronize all processes.
102  subroutine pmc_mpi_barrier()
103 
104 #ifdef PMC_USE_MPI
105  integer :: ierr
106 
107  call mpi_barrier(mpi_comm_world, ierr)
108  call pmc_mpi_check_ierr(ierr)
109 #endif
110 
111  end subroutine pmc_mpi_barrier
112 
113 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
114 
115  !> Returns the rank of the current process.
116  integer function pmc_mpi_rank()
117 
118 #ifdef PMC_USE_MPI
119  integer :: rank, ierr
120 
121  call mpi_comm_rank(mpi_comm_world, rank, ierr)
122  call pmc_mpi_check_ierr(ierr)
123  pmc_mpi_rank = rank
124 #else
125  pmc_mpi_rank = 0
126 #endif
127 
128  end function pmc_mpi_rank
129 
130 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
131 
132  !> Returns the total number of processes.
133  integer function pmc_mpi_size()
134 
135 #ifdef PMC_USE_MPI
136  integer :: size, ierr
137 
138  call mpi_comm_size(mpi_comm_world, size, ierr)
139  call pmc_mpi_check_ierr(ierr)
140  pmc_mpi_size = size
141 #else
142  pmc_mpi_size = 1
143 #endif
144 
145  end function pmc_mpi_size
146 
147 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
148 
149  !> Perform basic sanity checks on send/receive.
150  subroutine pmc_mpi_test()
151 
152 #ifdef PMC_USE_MPI
153  real(kind=dp), parameter :: test_real = 2.718281828459d0
154  complex(kind=dc), parameter :: test_complex &
155  = (0.707106781187d0, 1.4142135624d0)
156  logical, parameter :: test_logical = .true.
157  character(len=100), parameter :: test_string &
158  = "a truth universally acknowledged"
159  integer, parameter :: test_integer = 314159
160 
161  character, allocatable :: buffer(:)
162  integer :: buffer_size, max_buffer_size, position
163  real(kind=dp) :: send_real, recv_real
164  complex(kind=dc) :: send_complex, recv_complex
165  logical :: send_logical, recv_logical
166  character(len=100) :: send_string, recv_string
167  integer :: send_integer, recv_integer
168  real(kind=dp) :: send_real_array(2)
169  real(kind=dp), pointer :: recv_real_array(:)
170 
171  allocate(recv_real_array(1))
172 
173  if (pmc_mpi_rank() == 0) then
174  send_real = test_real
175  send_complex = test_complex
176  send_logical = test_logical
177  send_string = test_string
178  send_integer = test_integer
179  send_real_array(1) = real(test_complex)
180  send_real_array(2) = aimag(test_complex)
181 
182  max_buffer_size = 0
183  max_buffer_size = max_buffer_size &
184  + pmc_mpi_pack_size_integer(send_integer)
185  max_buffer_size = max_buffer_size &
186  + pmc_mpi_pack_size_real(send_real)
187  max_buffer_size = max_buffer_size &
188  + pmc_mpi_pack_size_complex(send_complex)
189  max_buffer_size = max_buffer_size &
190  + pmc_mpi_pack_size_logical(send_logical)
191  max_buffer_size = max_buffer_size &
192  + pmc_mpi_pack_size_string(send_string)
193  max_buffer_size = max_buffer_size &
194  + pmc_mpi_pack_size_real_array(send_real_array)
195 
196  allocate(buffer(max_buffer_size))
197 
198  position = 0
199  call pmc_mpi_pack_real(buffer, position, send_real)
200  call pmc_mpi_pack_complex(buffer, position, send_complex)
201  call pmc_mpi_pack_logical(buffer, position, send_logical)
202  call pmc_mpi_pack_string(buffer, position, send_string)
203  call pmc_mpi_pack_integer(buffer, position, send_integer)
204  call pmc_mpi_pack_real_array(buffer, position, send_real_array)
205  call assert_msg(350740830, position <= max_buffer_size, &
206  "MPI test failure: pack position " &
207  // trim(integer_to_string(position)) &
208  // " greater than max_buffer_size " &
209  // trim(integer_to_string(max_buffer_size)))
210  buffer_size = position ! might be less than we allocated
211  end if
212 
213  call pmc_mpi_bcast_integer(buffer_size)
214 
215  if (pmc_mpi_rank() /= 0) then
216  allocate(buffer(buffer_size))
217  end if
218 
219  call pmc_mpi_bcast_packed(buffer)
220 
221  if (pmc_mpi_rank() /= 0) then
222  position = 0
223  call pmc_mpi_unpack_real(buffer, position, recv_real)
224  call pmc_mpi_unpack_complex(buffer, position, recv_complex)
225  call pmc_mpi_unpack_logical(buffer, position, recv_logical)
226  call pmc_mpi_unpack_string(buffer, position, recv_string)
227  call pmc_mpi_unpack_integer(buffer, position, recv_integer)
228  call pmc_mpi_unpack_real_array(buffer, position, recv_real_array)
229  call assert_msg(787677020, position == buffer_size, &
230  "MPI test failure: unpack position " &
231  // trim(integer_to_string(position)) &
232  // " not equal to buffer_size " &
233  // trim(integer_to_string(buffer_size)))
234  end if
235 
236  deallocate(buffer)
237 
238  if (pmc_mpi_rank() /= 0) then
239  call assert_msg(567548916, recv_real == test_real, &
240  "MPI test failure: real recv " &
241  // trim(real_to_string(recv_real)) &
242  // " not equal to " &
243  // trim(real_to_string(test_real)))
244  call assert_msg(653908509, recv_complex == test_complex, &
245  "MPI test failure: complex recv " &
246  // trim(complex_to_string(recv_complex)) &
247  // " not equal to " &
248  // trim(complex_to_string(test_complex)))
249  call assert_msg(307746296, recv_logical .eqv. test_logical, &
250  "MPI test failure: logical recv " &
251  // trim(logical_to_string(recv_logical)) &
252  // " not equal to " &
253  // trim(logical_to_string(test_logical)))
254  call assert_msg(155693492, recv_string == test_string, &
255  "MPI test failure: string recv '" &
256  // trim(recv_string) &
257  // "' not equal to '" &
258  // trim(test_string) // "'")
259  call assert_msg(875699427, recv_integer == test_integer, &
260  "MPI test failure: integer recv " &
261  // trim(integer_to_string(recv_integer)) &
262  // " not equal to " &
263  // trim(integer_to_string(test_integer)))
264  call assert_msg(326982363, size(recv_real_array) == 2, &
265  "MPI test failure: real array recv size " &
266  // trim(integer_to_string(size(recv_real_array))) &
267  // " not equal to 2")
268  call assert_msg(744394323, &
269  recv_real_array(1) == real(test_complex), &
270  "MPI test failure: real array recv index 1 " &
271  // trim(real_to_string(recv_real_array(1))) &
272  // " not equal to " &
273  // trim(real_to_string(real(test_complex))))
274  call assert_msg(858902527, &
275  recv_real_array(2) == aimag(test_complex), &
276  "MPI test failure: real array recv index 2 " &
277  // trim(real_to_string(recv_real_array(2))) &
278  // " not equal to " &
279  // trim(real_to_string(aimag(test_complex))))
280  end if
281 
282  deallocate(recv_real_array)
283 #endif
284 
285  end subroutine pmc_mpi_test
286 
287 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
288 
289  !> Broadcast the given value from process 0 to all other processes.
290  subroutine pmc_mpi_bcast_integer(val)
291 
292  !> Value to broadcast.
293  integer, intent(inout) :: val
294 
295 #ifdef PMC_USE_MPI
296  integer :: root, ierr
297 
298  root = 0 ! source of data to broadcast
299  call mpi_bcast(val, 1, mpi_integer, root, &
300  mpi_comm_world, ierr)
301  call pmc_mpi_check_ierr(ierr)
302 #endif
303 
304  end subroutine pmc_mpi_bcast_integer
305 
306 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
307 
308  !> Broadcast the given value from process 0 to all other processes.
309  subroutine pmc_mpi_bcast_string(val)
310 
311  !> Value to broadcast.
312  character(len=*), intent(inout) :: val
313 
314 #ifdef PMC_USE_MPI
315  integer :: root, ierr
316 
317  root = 0 ! source of data to broadcast
318  call mpi_bcast(val, len(val), mpi_character, root, &
319  mpi_comm_world, ierr)
320  call pmc_mpi_check_ierr(ierr)
321 #endif
322 
323  end subroutine pmc_mpi_bcast_string
324 
325 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
326 
327  !> Broadcast the given value from process 0 to all other processes.
328  subroutine pmc_mpi_bcast_packed(val)
329 
330  !> Value to broadcast.
331  character, intent(inout) :: val(:)
332 
333 #ifdef PMC_USE_MPI
334  integer :: root, ierr
335 
336  root = 0 ! source of data to broadcast
337  call mpi_bcast(val, size(val), mpi_character, root, &
338  mpi_comm_world, ierr)
339  call pmc_mpi_check_ierr(ierr)
340 #endif
341 
342  end subroutine pmc_mpi_bcast_packed
343 
344 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
345 
346  !> Determines the number of bytes required to pack the given value.
347  integer function pmc_mpi_pack_size_integer(val)
348 
349  !> Value to pack.
350  integer, intent(in) :: val
351 
352  integer :: ierr
353 
354 #ifdef PMC_USE_MPI
355  call mpi_pack_size(1, mpi_integer, mpi_comm_world, &
357  call pmc_mpi_check_ierr(ierr)
358 #else
360 #endif
361 
362  end function pmc_mpi_pack_size_integer
363 
364 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
365 
366  !> Determines the number of bytes required to pack the given value.
367  integer function pmc_mpi_pack_size_real(val)
368 
369  !> Value to pack.
370  real(kind=dp), intent(in) :: val
371 
372  integer :: ierr
373 
374 #ifdef PMC_USE_MPI
375  call mpi_pack_size(1, mpi_double_precision, mpi_comm_world, &
377  call pmc_mpi_check_ierr(ierr)
378 #else
380 #endif
381 
382  end function pmc_mpi_pack_size_real
383 
384 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
385 
386  !> Determines the number of bytes required to pack the given value.
387  integer function pmc_mpi_pack_size_string(val)
388 
389  !> Value to pack.
390  character(len=*), intent(in) :: val
391 
392  integer :: ierr
393 
394 #ifdef PMC_USE_MPI
395  call mpi_pack_size(len_trim(val), mpi_character, mpi_comm_world, &
397  call pmc_mpi_check_ierr(ierr)
399  + pmc_mpi_pack_size_integer(len_trim(val))
400 #else
402 #endif
403 
404  end function pmc_mpi_pack_size_string
405 
406 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
407 
408  !> Determines the number of bytes required to pack the given value.
409  integer function pmc_mpi_pack_size_logical(val)
410 
411  !> Value to pack.
412  logical, intent(in) :: val
413 
414  integer :: ierr
415 
416 #ifdef PMC_USE_MPI
417  call mpi_pack_size(1, mpi_logical, mpi_comm_world, &
419  call pmc_mpi_check_ierr(ierr)
420 #else
422 #endif
423 
424  end function pmc_mpi_pack_size_logical
425 
426 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
427 
428  !> Determines the number of bytes required to pack the given value.
429  integer function pmc_mpi_pack_size_complex(val)
430 
431  !> Value to pack.
432  complex(kind=dc), intent(in) :: val
433 
434  integer :: ierr
435 
436 #ifdef PMC_USE_MPI
437  call mpi_pack_size(1, mpi_double_complex, mpi_comm_world, &
439  call pmc_mpi_check_ierr(ierr)
440 #else
442 #endif
443 
444  end function pmc_mpi_pack_size_complex
445 
446 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
447 
448  !> Determines the number of bytes required to pack the given value.
449  integer function pmc_mpi_pack_size_integer_array(val)
450 
451  !> Value to pack.
452  integer, intent(in) :: val(:)
453 
454  integer :: ierr
455 
456 #ifdef PMC_USE_MPI
457  call mpi_pack_size(size(val), mpi_integer, mpi_comm_world, &
459  call pmc_mpi_check_ierr(ierr)
461  + pmc_mpi_pack_size_integer(size(val))
462 #else
464 #endif
465 
467 
468 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
469 
470  !> Determines the number of bytes required to pack the given value.
471  integer function pmc_mpi_pack_size_real_array(val)
472 
473  !> Value to pack.
474  real(kind=dp), intent(in) :: val(:)
475 
476  integer :: ierr
477 
478 #ifdef PMC_USE_MPI
479  call mpi_pack_size(size(val), mpi_double_precision, mpi_comm_world, &
481  call pmc_mpi_check_ierr(ierr)
483  + pmc_mpi_pack_size_integer(size(val))
484 #else
486 #endif
487 
488  end function pmc_mpi_pack_size_real_array
489 
490 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
491 
492  !> Determines the number of bytes required to pack the given value.
493  integer function pmc_mpi_pack_size_string_array(val)
494 
495  !> Value to pack.
496  character(len=*), intent(in) :: val(:)
497 
498  integer :: i, total_size
499 
500  total_size = pmc_mpi_pack_size_integer(size(val))
501  do i = 1,size(val)
502  total_size = total_size + pmc_mpi_pack_size_string(val(i))
503  end do
504  pmc_mpi_pack_size_string_array = total_size
505 
506  end function pmc_mpi_pack_size_string_array
507 
508 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
509 
510  !> Determines the number of bytes required to pack the given value.
511  integer function pmc_mpi_pack_size_real_array_2d(val)
512 
513  !> Value to pack.
514  real(kind=dp), intent(in) :: val(:,:)
515 
516  integer :: ierr
517 
518 #ifdef PMC_USE_MPI
519  call mpi_pack_size(size(val), mpi_double_precision, mpi_comm_world, &
521  call pmc_mpi_check_ierr(ierr)
523  + pmc_mpi_pack_size_integer(size(val,1)) &
524  + pmc_mpi_pack_size_integer(size(val,2))
525 #else
527 #endif
528 
530 
531 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
532 
533  !> Packs the given value into the buffer, advancing position.
534  subroutine pmc_mpi_pack_integer(buffer, position, val)
535 
536  !> Memory buffer.
537  character, intent(inout) :: buffer(:)
538  !> Current buffer position.
539  integer, intent(inout) :: position
540  !> Value to pack.
541  integer, intent(in) :: val
542 
543 #ifdef PMC_USE_MPI
544  integer :: prev_position, ierr
545 
546  prev_position = position
547  call mpi_pack(val, 1, mpi_integer, buffer, size(buffer), &
548  position, mpi_comm_world, ierr)
549  call pmc_mpi_check_ierr(ierr)
550  call assert(913495993, &
551  position - prev_position <= pmc_mpi_pack_size_integer(val))
552 #endif
553 
554  end subroutine pmc_mpi_pack_integer
555 
556 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
557 
558  !> Packs the given value into the buffer, advancing position.
559  subroutine pmc_mpi_pack_real(buffer, position, val)
560 
561  !> Memory buffer.
562  character, intent(inout) :: buffer(:)
563  !> Current buffer position.
564  integer, intent(inout) :: position
565  !> Value to pack.
566  real(kind=dp), intent(in) :: val
567 
568 #ifdef PMC_USE_MPI
569  integer :: prev_position, ierr
570 
571  prev_position = position
572  call mpi_pack(val, 1, mpi_double_precision, buffer, size(buffer), &
573  position, mpi_comm_world, ierr)
574  call pmc_mpi_check_ierr(ierr)
575  call assert(395354132, &
576  position - prev_position <= pmc_mpi_pack_size_real(val))
577 #endif
578 
579  end subroutine pmc_mpi_pack_real
580 
581 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
582 
583  !> Packs the given value into the buffer, advancing position.
584  subroutine pmc_mpi_pack_string(buffer, position, val)
585 
586  !> Memory buffer.
587  character, intent(inout) :: buffer(:)
588  !> Current buffer position.
589  integer, intent(inout) :: position
590  !> Value to pack.
591  character(len=*), intent(in) :: val
592 
593 #ifdef PMC_USE_MPI
594  integer :: prev_position, length, ierr
595 
596  prev_position = position
597  length = len_trim(val)
598  call pmc_mpi_pack_integer(buffer, position, length)
599  call mpi_pack(val, length, mpi_character, buffer, size(buffer), &
600  position, mpi_comm_world, ierr)
601  call pmc_mpi_check_ierr(ierr)
602  call assert(607212018, &
603  position - prev_position <= pmc_mpi_pack_size_string(val))
604 #endif
605 
606  end subroutine pmc_mpi_pack_string
607 
608 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
609 
610  !> Packs the given value into the buffer, advancing position.
611  subroutine pmc_mpi_pack_logical(buffer, position, val)
612 
613  !> Memory buffer.
614  character, intent(inout) :: buffer(:)
615  !> Current buffer position.
616  integer, intent(inout) :: position
617  !> Value to pack.
618  logical, intent(in) :: val
619 
620 #ifdef PMC_USE_MPI
621  integer :: prev_position, ierr
622 
623  prev_position = position
624  call mpi_pack(val, 1, mpi_logical, buffer, size(buffer), &
625  position, mpi_comm_world, ierr)
626  call pmc_mpi_check_ierr(ierr)
627  call assert(104535200, &
628  position - prev_position <= pmc_mpi_pack_size_logical(val))
629 #endif
630 
631  end subroutine pmc_mpi_pack_logical
632 
633 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
634 
635  !> Packs the given value into the buffer, advancing position.
636  subroutine pmc_mpi_pack_complex(buffer, position, val)
637 
638  !> Memory buffer.
639  character, intent(inout) :: buffer(:)
640  !> Current buffer position.
641  integer, intent(inout) :: position
642  !> Value to pack.
643  complex(kind=dc), intent(in) :: val
644 
645 #ifdef PMC_USE_MPI
646  integer :: prev_position, ierr
647 
648  prev_position = position
649  call mpi_pack(val, 1, mpi_double_complex, buffer, size(buffer), &
650  position, mpi_comm_world, ierr)
651  call pmc_mpi_check_ierr(ierr)
652  call assert(640416372, &
653  position - prev_position <= pmc_mpi_pack_size_complex(val))
654 #endif
655 
656  end subroutine pmc_mpi_pack_complex
657 
658 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
659 
660  !> Packs the given value into the buffer, advancing position.
661  subroutine pmc_mpi_pack_integer_array(buffer, position, val)
662 
663  !> Memory buffer.
664  character, intent(inout) :: buffer(:)
665  !> Current buffer position.
666  integer, intent(inout) :: position
667  !> Value to pack.
668  integer, intent(in) :: val(:)
669 
670 #ifdef PMC_USE_MPI
671  integer :: prev_position, n, ierr
672 
673  prev_position = position
674  n = size(val)
675  call pmc_mpi_pack_integer(buffer, position, n)
676  call mpi_pack(val, n, mpi_integer, buffer, size(buffer), &
677  position, mpi_comm_world, ierr)
678  call pmc_mpi_check_ierr(ierr)
679  call assert(698601296, &
680  position - prev_position <= pmc_mpi_pack_size_integer_array(val))
681 #endif
682 
683  end subroutine pmc_mpi_pack_integer_array
684 
685 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
686 
687  !> Packs the given value into the buffer, advancing position.
688  subroutine pmc_mpi_pack_real_array(buffer, position, val)
689 
690  !> Memory buffer.
691  character, intent(inout) :: buffer(:)
692  !> Current buffer position.
693  integer, intent(inout) :: position
694  !> Value to pack.
695  real(kind=dp), intent(in) :: val(:)
696 
697 #ifdef PMC_USE_MPI
698  integer :: prev_position, n, ierr
699 
700  prev_position = position
701  n = size(val)
702  call pmc_mpi_pack_integer(buffer, position, n)
703  call mpi_pack(val, n, mpi_double_precision, buffer, size(buffer), &
704  position, mpi_comm_world, ierr)
705  call pmc_mpi_check_ierr(ierr)
706  call assert(825718791, &
707  position - prev_position <= pmc_mpi_pack_size_real_array(val))
708 #endif
709 
710  end subroutine pmc_mpi_pack_real_array
711 
712 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
713 
714  !> Packs the given value into the buffer, advancing position.
715  subroutine pmc_mpi_pack_string_array(buffer, position, val)
716 
717  !> Memory buffer.
718  character, intent(inout) :: buffer(:)
719  !> Current buffer position.
720  integer, intent(inout) :: position
721  !> Value to pack.
722  character(len=*), intent(in) :: val(:)
723 
724 #ifdef PMC_USE_MPI
725  integer :: prev_position, i, n
726 
727  prev_position = position
728  n = size(val)
729  call pmc_mpi_pack_integer(buffer, position, n)
730  do i = 1,n
731  call pmc_mpi_pack_string(buffer, position, val(i))
732  end do
733  call assert(630900704, &
734  position - prev_position <= pmc_mpi_pack_size_string_array(val))
735 #endif
736 
737  end subroutine pmc_mpi_pack_string_array
738 
739 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
740 
741  !> Packs the given value into the buffer, advancing position.
742  subroutine pmc_mpi_pack_real_array_2d(buffer, position, val)
743 
744  !> Memory buffer.
745  character, intent(inout) :: buffer(:)
746  !> Current buffer position.
747  integer, intent(inout) :: position
748  !> Value to pack.
749  real(kind=dp), intent(in) :: val(:,:)
750 
751 #ifdef PMC_USE_MPI
752  integer :: prev_position, n1, n2, ierr
753 
754  prev_position = position
755  n1 = size(val, 1)
756  n2 = size(val, 2)
757  call pmc_mpi_pack_integer(buffer, position, n1)
758  call pmc_mpi_pack_integer(buffer, position, n2)
759  call mpi_pack(val, n1*n2, mpi_double_precision, buffer, size(buffer), &
760  position, mpi_comm_world, ierr)
761  call pmc_mpi_check_ierr(ierr)
762  call assert(567349745, &
763  position - prev_position <= pmc_mpi_pack_size_real_array_2d(val))
764 #endif
765 
766  end subroutine pmc_mpi_pack_real_array_2d
767 
768 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
769 
770  !> Unpacks the given value from the buffer, advancing position.
771  subroutine pmc_mpi_unpack_integer(buffer, position, val)
772 
773  !> Memory buffer.
774  character, intent(inout) :: buffer(:)
775  !> Current buffer position.
776  integer, intent(inout) :: position
777  !> Value to pack.
778  integer, intent(out) :: val
779 
780 #ifdef PMC_USE_MPI
781  integer :: prev_position, ierr
782 
783  prev_position = position
784  call mpi_unpack(buffer, size(buffer), position, val, 1, mpi_integer, &
785  mpi_comm_world, ierr)
786  call pmc_mpi_check_ierr(ierr)
787  call assert(890243339, &
788  position - prev_position <= pmc_mpi_pack_size_integer(val))
789 #endif
790 
791  end subroutine pmc_mpi_unpack_integer
792 
793 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
794 
795  !> Unpacks the given value from the buffer, advancing position.
796  subroutine pmc_mpi_unpack_real(buffer, position, val)
797 
798  !> Memory buffer.
799  character, intent(inout) :: buffer(:)
800  !> Current buffer position.
801  integer, intent(inout) :: position
802  !> Value to pack.
803  real(kind=dp), intent(out) :: val
804 
805 #ifdef PMC_USE_MPI
806  integer :: prev_position, ierr
807 
808  prev_position = position
809  call mpi_unpack(buffer, size(buffer), position, val, 1, &
810  mpi_double_precision, mpi_comm_world, ierr)
811  call pmc_mpi_check_ierr(ierr)
812  call assert(570771632, &
813  position - prev_position <= pmc_mpi_pack_size_real(val))
814 #endif
815 
816  end subroutine pmc_mpi_unpack_real
817 
818 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
819 
820  !> Unpacks the given value from the buffer, advancing position.
821  subroutine pmc_mpi_unpack_string(buffer, position, val)
822 
823  !> Memory buffer.
824  character, intent(inout) :: buffer(:)
825  !> Current buffer position.
826  integer, intent(inout) :: position
827  !> Value to pack.
828  character(len=*), intent(out) :: val
829 
830 #ifdef PMC_USE_MPI
831  integer :: prev_position, length, ierr
832 
833  prev_position = position
834  call pmc_mpi_unpack_integer(buffer, position, length)
835  call assert(946399479, length <= len(val))
836  val = ''
837  call mpi_unpack(buffer, size(buffer), position, val, length, &
838  mpi_character, mpi_comm_world, ierr)
839  call pmc_mpi_check_ierr(ierr)
840  call assert(503378058, &
841  position - prev_position <= pmc_mpi_pack_size_string(val))
842 #endif
843 
844  end subroutine pmc_mpi_unpack_string
845 
846 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
847 
848  !> Unpacks the given value from the buffer, advancing position.
849  subroutine pmc_mpi_unpack_logical(buffer, position, val)
850 
851  !> Memory buffer.
852  character, intent(inout) :: buffer(:)
853  !> Current buffer position.
854  integer, intent(inout) :: position
855  !> Value to pack.
856  logical, intent(out) :: val
857 
858 #ifdef PMC_USE_MPI
859  integer :: prev_position, ierr
860 
861  prev_position = position
862  call mpi_unpack(buffer, size(buffer), position, val, 1, mpi_logical, &
863  mpi_comm_world, ierr)
864  call pmc_mpi_check_ierr(ierr)
865  call assert(694750528, &
866  position - prev_position <= pmc_mpi_pack_size_logical(val))
867 #endif
868 
869  end subroutine pmc_mpi_unpack_logical
870 
871 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
872 
873  !> Unpacks the given value from the buffer, advancing position.
874  subroutine pmc_mpi_unpack_complex(buffer, position, val)
875 
876  !> Memory buffer.
877  character, intent(inout) :: buffer(:)
878  !> Current buffer position.
879  integer, intent(inout) :: position
880  !> Value to pack.
881  complex(kind=dc), intent(out) :: val
882 
883 #ifdef PMC_USE_MPI
884  integer :: prev_position, ierr
885 
886  prev_position = position
887  call mpi_unpack(buffer, size(buffer), position, val, 1, &
888  mpi_double_complex, mpi_comm_world, ierr)
889  call pmc_mpi_check_ierr(ierr)
890  call assert(969672634, &
891  position - prev_position <= pmc_mpi_pack_size_complex(val))
892 #endif
893 
894  end subroutine pmc_mpi_unpack_complex
895 
896 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
897 
898  !> Unpacks the given value from the buffer, advancing position.
899  subroutine pmc_mpi_unpack_integer_array(buffer, position, val)
900 
901  !> Memory buffer.
902  character, intent(inout) :: buffer(:)
903  !> Current buffer position.
904  integer, intent(inout) :: position
905  !> Value to pack.
906  integer, pointer :: val(:)
907 
908 #ifdef PMC_USE_MPI
909  integer :: prev_position, n, ierr
910 
911  prev_position = position
912  call pmc_mpi_unpack_integer(buffer, position, n)
913  deallocate(val)
914  allocate(val(n))
915  call mpi_unpack(buffer, size(buffer), position, val, n, mpi_integer, &
916  mpi_comm_world, ierr)
917  call pmc_mpi_check_ierr(ierr)
918  call assert(565840919, &
919  position - prev_position <= pmc_mpi_pack_size_integer_array(val))
920 #endif
921 
922  end subroutine pmc_mpi_unpack_integer_array
923 
924 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
925 
926  !> Unpacks the given value from the buffer, advancing position.
927  subroutine pmc_mpi_unpack_real_array(buffer, position, val)
928 
929  !> Memory buffer.
930  character, intent(inout) :: buffer(:)
931  !> Current buffer position.
932  integer, intent(inout) :: position
933  !> Value to pack.
934  real(kind=dp), pointer :: val(:)
935 
936 #ifdef PMC_USE_MPI
937  integer :: prev_position, n, ierr
938 
939  prev_position = position
940  call pmc_mpi_unpack_integer(buffer, position, n)
941  deallocate(val)
942  allocate(val(n))
943  call mpi_unpack(buffer, size(buffer), position, val, n, &
944  mpi_double_precision, mpi_comm_world, ierr)
945  call pmc_mpi_check_ierr(ierr)
946  call assert(782875761, &
947  position - prev_position <= pmc_mpi_pack_size_real_array(val))
948 #endif
949 
950  end subroutine pmc_mpi_unpack_real_array
951 
952 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
953 
954  !> Unpacks the given value from the buffer, advancing position.
955  subroutine pmc_mpi_unpack_string_array(buffer, position, val)
956 
957  !> Memory buffer.
958  character, intent(inout) :: buffer(:)
959  !> Current buffer position.
960  integer, intent(inout) :: position
961  !> Value to pack.
962  character(len=*), pointer :: val(:)
963 
964 #ifdef PMC_USE_MPI
965  integer :: prev_position, i, n
966 
967  prev_position = position
968  call pmc_mpi_unpack_integer(buffer, position, n)
969  deallocate(val)
970  allocate(val(n))
971  do i = 1,n
972  call pmc_mpi_unpack_string(buffer, position, val(i))
973  end do
974  call assert(320065648, &
975  position - prev_position <= pmc_mpi_pack_size_string_array(val))
976 #endif
977 
978  end subroutine pmc_mpi_unpack_string_array
979 
980 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
981 
982  !> Unpacks the given value from the buffer, advancing position.
983  subroutine pmc_mpi_unpack_real_array_2d(buffer, position, val)
984 
985  !> Memory buffer.
986  character, intent(inout) :: buffer(:)
987  !> Current buffer position.
988  integer, intent(inout) :: position
989  !> Value to pack.
990  real(kind=dp), pointer :: val(:,:)
991 
992 #ifdef PMC_USE_MPI
993  integer :: prev_position, n1, n2, ierr
994 
995  prev_position = position
996  call pmc_mpi_unpack_integer(buffer, position, n1)
997  call pmc_mpi_unpack_integer(buffer, position, n2)
998  deallocate(val)
999  allocate(val(n1,n2))
1000  call mpi_unpack(buffer, size(buffer), position, val, n1*n2, &
1001  mpi_double_precision, mpi_comm_world, ierr)
1002  call pmc_mpi_check_ierr(ierr)
1003  call assert(781681739, position - prev_position &
1005 #endif
1006 
1007  end subroutine pmc_mpi_unpack_real_array_2d
1008 
1009 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1010 
1011  !> Computes the average of val across all processes, storing the
1012  !> result in val_avg on the root process.
1013  subroutine pmc_mpi_reduce_avg_real(val, val_avg)
1014 
1015  !> Value to average.
1016  real(kind=dp), intent(in) :: val
1017  !> Result.
1018  real(kind=dp), intent(out) :: val_avg
1019 
1020 #ifdef PMC_USE_MPI
1021  integer :: ierr
1022 
1023  call mpi_reduce(val, val_avg, 1, mpi_double_precision, mpi_sum, 0, &
1024  mpi_comm_world, ierr)
1025  call pmc_mpi_check_ierr(ierr)
1026  if (pmc_mpi_rank() == 0) then
1027  val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
1028  end if
1029 #else
1030  val_avg = val
1031 #endif
1032 
1033  end subroutine pmc_mpi_reduce_avg_real
1034 
1035 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1036 
1037  !> Transfer the value between the given processes.
1038  subroutine pmc_mpi_transfer_real(from_val, to_val, from_proc, to_proc)
1039 
1040  !> Value to send.
1041  real(kind=dp), intent(in) :: from_val
1042  !> Variable to send to.
1043  real(kind=dp), intent(out) :: to_val
1044  !> Process to send from.
1045  integer, intent(in) :: from_proc
1046  !> Process to send to.
1047  integer, intent(in) :: to_proc
1048 
1049 #ifdef PMC_USE_MPI
1050  integer :: rank, ierr, status(mpi_status_size)
1051 
1052  rank = pmc_mpi_rank()
1053  if (from_proc == to_proc) then
1054  if (rank == from_proc) then
1055  to_val = from_val
1056  end if
1057  else
1058  if (rank == from_proc) then
1059  call mpi_send(from_val, 1, mpi_double_precision, to_proc, &
1060  208020430, mpi_comm_world, ierr)
1061  call pmc_mpi_check_ierr(ierr)
1062  elseif (rank == to_proc) then
1063  call mpi_recv(to_val, 1, mpi_double_precision, from_proc, &
1064  208020430, mpi_comm_world, status, ierr)
1065  call pmc_mpi_check_ierr(ierr)
1066  end if
1067  end if
1068 #else
1069  to_val = from_val
1070 #endif
1071 
1072  end subroutine pmc_mpi_transfer_real
1073 
1074 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1075 
1076  !> Transfer the value between the given processes.
1077  subroutine pmc_mpi_transfer_integer(from_val, to_val, from_proc, to_proc)
1078 
1079  !> Value to send.
1080  integer, intent(in) :: from_val
1081  !> Variable to send to.
1082  integer, intent(out) :: to_val
1083  !> Process to send from.
1084  integer, intent(in) :: from_proc
1085  !> Process to send to.
1086  integer, intent(in) :: to_proc
1087 
1088 #ifdef PMC_USE_MPI
1089  integer :: rank, ierr, status(mpi_status_size)
1090 
1091  rank = pmc_mpi_rank()
1092  if (from_proc == to_proc) then
1093  if (rank == from_proc) then
1094  to_val = from_val
1095  end if
1096  else
1097  if (rank == from_proc) then
1098  call mpi_send(from_val, 1, mpi_integer, to_proc, &
1099  208020430, mpi_comm_world, ierr)
1100  call pmc_mpi_check_ierr(ierr)
1101  elseif (rank == to_proc) then
1102  call mpi_recv(to_val, 1, mpi_integer, from_proc, &
1103  208020430, mpi_comm_world, status, ierr)
1104  call pmc_mpi_check_ierr(ierr)
1105  end if
1106  end if
1107 #else
1108  to_val = from_val
1109 #endif
1110 
1111  end subroutine pmc_mpi_transfer_integer
1112 
1113 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1114 
1115  !> Computes the sum of \c val across all processes, storing the
1116  !> result in \c val_sum on the root process.
1117  subroutine pmc_mpi_reduce_sum_integer(val, val_sum)
1118 
1119  !> Value to sum.
1120  integer, intent(in) :: val
1121  !> Result.
1122  integer, intent(out) :: val_sum
1123 
1124 #ifdef PMC_USE_MPI
1125  integer :: ierr
1126 
1127  call mpi_reduce(val, val_sum, 1, mpi_integer, mpi_sum, 0, &
1128  mpi_comm_world, ierr)
1129  call pmc_mpi_check_ierr(ierr)
1130 #else
1131  val_sum = val
1132 #endif
1133 
1134  end subroutine pmc_mpi_reduce_sum_integer
1135 
1136 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1137 
1138  !> Computes the sum of \c val across all processes, storing the
1139  !> result in \c val_sum on all processes.
1140  subroutine pmc_mpi_allreduce_sum_integer(val, val_sum)
1141 
1142  !> Value to sum.
1143  integer, intent(in) :: val
1144  !> Result.
1145  integer, intent(out) :: val_sum
1146 
1147 #ifdef PMC_USE_MPI
1148  integer :: ierr
1149 
1150  call mpi_allreduce(val, val_sum, 1, mpi_integer, mpi_sum, &
1151  mpi_comm_world, ierr)
1152  call pmc_mpi_check_ierr(ierr)
1153 #else
1154  val_sum = val
1155 #endif
1156 
1157  end subroutine pmc_mpi_allreduce_sum_integer
1158 
1159 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1160 
1161  !> Computes the average of val across all processes, storing the
1162  !> result in val_avg on the root process.
1163  subroutine pmc_mpi_reduce_avg_real_array(val, val_avg)
1164 
1165  !> Value to average.
1166  real(kind=dp), intent(in) :: val(:)
1167  !> Result.
1168  real(kind=dp), intent(out) :: val_avg(:)
1169 
1170 #ifdef PMC_USE_MPI
1171  integer :: ierr
1172 
1173  call assert(915136121, size(val) == size(val_avg))
1174  call mpi_reduce(val, val_avg, size(val), mpi_double_precision, &
1175  mpi_sum, 0, mpi_comm_world, ierr)
1176  call pmc_mpi_check_ierr(ierr)
1177  if (pmc_mpi_rank() == 0) then
1178  val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
1179  end if
1180 #else
1181  val_avg = val
1182 #endif
1183 
1184  end subroutine pmc_mpi_reduce_avg_real_array
1185 
1186 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1187 
1188  !> Computes the average of val across all processes, storing the
1189  !> result in val_avg on the root process.
1190  subroutine pmc_mpi_reduce_avg_real_array_2d(val, val_avg)
1191 
1192  !> Value to average.
1193  real(kind=dp), intent(in) :: val(:,:)
1194  !> Result.
1195  real(kind=dp), intent(out) :: val_avg(:,:)
1196 
1197 #ifdef PMC_USE_MPI
1198  integer :: ierr
1199 
1200  call assert(131229046, size(val,1) == size(val_avg,1))
1201  call assert(992122167, size(val,2) == size(val_avg,2))
1202  call mpi_reduce(val, val_avg, size(val), mpi_double_precision, &
1203  mpi_sum, 0, mpi_comm_world, ierr)
1204  call pmc_mpi_check_ierr(ierr)
1205  if (pmc_mpi_rank() == 0) then
1206  val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
1207  end if
1208 #else
1209  val_avg = val
1210 #endif
1211 
1212  end subroutine pmc_mpi_reduce_avg_real_array_2d
1213 
1214 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1215 
1216  !> Computes the average of val across all processes, storing the
1217  !> result in val_avg on all processes.
1218  subroutine pmc_mpi_allreduce_average_real(val, val_avg)
1219 
1220  !> Value to average.
1221  real(kind=dp), intent(in) :: val
1222  !> Result.
1223  real(kind=dp), intent(out) :: val_avg
1224 
1225 #ifdef PMC_USE_MPI
1226  integer :: ierr
1227 
1228  call mpi_allreduce(val, val_avg, 1, mpi_double_precision, mpi_sum, &
1229  mpi_comm_world, ierr)
1230  call pmc_mpi_check_ierr(ierr)
1231  val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
1232 #else
1233  val_avg = val
1234 #endif
1235 
1236  end subroutine pmc_mpi_allreduce_average_real
1237 
1238 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1239 
1240  !> Computes the average of val across all processes, storing the
1241  !> result in val_avg on all processes.
1242  subroutine pmc_mpi_allreduce_average_real_array(val, val_avg)
1243 
1244  !> Value to average.
1245  real(kind=dp), intent(in) :: val(:)
1246  !> Result.
1247  real(kind=dp), intent(out) :: val_avg(:)
1248 
1249 #ifdef PMC_USE_MPI
1250  integer :: ierr
1251 
1252  call assert(948533359, size(val) == size(val_avg))
1253  call mpi_allreduce(val, val_avg, size(val), mpi_double_precision, &
1254  mpi_sum, mpi_comm_world, ierr)
1255  call pmc_mpi_check_ierr(ierr)
1256  val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
1257 #else
1258  val_avg = val
1259 #endif
1260 
1262 
1263 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1264 
1265  !> Computes the minimum of val across all processes, storing the
1266  !> result in val_min on all processes.
1267  subroutine pmc_mpi_allreduce_min_integer(val, val_min)
1268 
1269  !> Value to minimize.
1270  integer, intent(in) :: val
1271  !> Result.
1272  integer, intent(out) :: val_min
1273 
1274 #ifdef PMC_USE_MPI
1275  integer :: ierr
1276 
1277  call mpi_allreduce(val, val_min, 1, mpi_integer, mpi_min, &
1278  mpi_comm_world, ierr)
1279  call pmc_mpi_check_ierr(ierr)
1280 #else
1281  val_min = val
1282 #endif
1283 
1284  end subroutine pmc_mpi_allreduce_min_integer
1285 
1286 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1287 
1288  !> Computes the maximum of val across all processes, storing the
1289  !> result in val_max on all processes.
1290  subroutine pmc_mpi_allreduce_max_integer(val, val_max)
1291 
1292  !> Value to maximize.
1293  integer, intent(in) :: val
1294  !> Result.
1295  integer, intent(out) :: val_max
1296 
1297 #ifdef PMC_USE_MPI
1298  integer :: ierr
1299 
1300  call mpi_allreduce(val, val_max, 1, mpi_integer, mpi_max, &
1301  mpi_comm_world, ierr)
1302  call pmc_mpi_check_ierr(ierr)
1303 #else
1304  val_max = val
1305 #endif
1306 
1307  end subroutine pmc_mpi_allreduce_max_integer
1308 
1309 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1310 
1311  !> Computes the minimum of val across all processes, storing the
1312  !> result in val_min on all processes.
1313  subroutine pmc_mpi_allreduce_min_real(val, val_min)
1314 
1315  !> Value to minimize.
1316  real(kind=dp), intent(in) :: val
1317  !> Result.
1318  real(kind=dp), intent(out) :: val_min
1319 
1320 #ifdef PMC_USE_MPI
1321  integer :: ierr
1322 
1323  call mpi_allreduce(val, val_min, 1, mpi_double_precision, mpi_min, &
1324  mpi_comm_world, ierr)
1325  call pmc_mpi_check_ierr(ierr)
1326 #else
1327  val_min = val
1328 #endif
1329 
1330  end subroutine pmc_mpi_allreduce_min_real
1331 
1332 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1333 
1334  !> Computes the maximum of val across all processes, storing the
1335  !> result in val_max on all processes.
1336  subroutine pmc_mpi_allreduce_max_real(val, val_max)
1337 
1338  !> Value to maximize.
1339  real(kind=dp), intent(in) :: val
1340  !> Result.
1341  real(kind=dp), intent(out) :: val_max
1342 
1343 #ifdef PMC_USE_MPI
1344  integer :: ierr
1345 
1346  call mpi_allreduce(val, val_max, 1, mpi_double_precision, mpi_max, &
1347  mpi_comm_world, ierr)
1348  call pmc_mpi_check_ierr(ierr)
1349 #else
1350  val_max = val
1351 #endif
1352 
1353  end subroutine pmc_mpi_allreduce_max_real
1354 
1355 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1356 
1357  !> Returns whether all processors have the same value.
1358  logical function pmc_mpi_allequal_integer(val)
1359 
1360  !> Value to compare.
1361  integer, intent(in) :: val
1362 
1363 #ifdef PMC_USE_MPI
1364  integer :: min_val, max_val
1365 
1366  call pmc_mpi_allreduce_min_integer(val, min_val)
1367  call pmc_mpi_allreduce_max_integer(val, max_val)
1368  if (min_val == max_val) then
1369  pmc_mpi_allequal_integer = .true.
1370  else
1371  pmc_mpi_allequal_integer = .false.
1372  end if
1373 #else
1374  pmc_mpi_allequal_integer = .true.
1375 #endif
1376 
1377  end function pmc_mpi_allequal_integer
1378 
1379 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1380 
1381  !> Returns whether all processors have the same value.
1382  logical function pmc_mpi_allequal_real(val)
1383 
1384  !> Value to compare.
1385  real(kind=dp), intent(in) :: val
1386 
1387 #ifdef PMC_USE_MPI
1388  real(kind=dp) :: min_val, max_val
1389 
1390  call pmc_mpi_allreduce_min_real(val, min_val)
1391  call pmc_mpi_allreduce_max_real(val, max_val)
1392  if (min_val == max_val) then
1393  pmc_mpi_allequal_real = .true.
1394  else
1395  pmc_mpi_allequal_real = .false.
1396  end if
1397 #else
1398  pmc_mpi_allequal_real = .true.
1399 #endif
1400 
1401  end function pmc_mpi_allequal_real
1402 
1403 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1404 
1405  !> Does an all-to-all transfer of integers.
1406  subroutine pmc_mpi_alltoall_integer(send, recv)
1407 
1408  !> Values to send (must be one per process).
1409  integer, intent(in) :: send(:)
1410  !> Values to receive (must be one per process).
1411  integer, intent(out) :: recv(size(send))
1412 
1413 #ifdef PMC_USE_MPI
1414  integer :: ierr
1415 
1416  call mpi_alltoall(send, 1, mpi_integer, recv, 1, mpi_integer, &
1417  mpi_comm_world, ierr)
1418  call pmc_mpi_check_ierr(ierr)
1419 #else
1420  recv = send
1421 #endif
1422 
1423  end subroutine pmc_mpi_alltoall_integer
1424 
1425 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1426 
1427  !> Does an allgather of integer arrays (must be the same size on all
1428  !> processes).
1429  subroutine pmc_mpi_allgather_integer_array(send, recv)
1430 
1431  !> Values to send on each process.
1432  integer, intent(in) :: send(:)
1433  !> Values to receive (will be the same on all processes.
1434  integer, intent(out) :: recv(:,:)
1435 
1436 #ifdef PMC_USE_MPI
1437  integer :: n_proc, n_bin, n_data, ierr
1438  integer, allocatable :: send_buf(:), recv_buf(:)
1439 
1440  n_proc = pmc_mpi_size()
1441  n_data = size(send, 1)
1442  call assert(353005542, all(shape(recv) == (/n_data, n_proc/)))
1443 
1444  ! use a new send_buf to make sure the memory is contiguous
1445  allocate(send_buf(n_data))
1446  allocate(recv_buf(n_data * n_proc))
1447  send_buf = send
1448  call mpi_allgather(send_buf, n_data, mpi_integer, &
1449  recv_buf, n_data, mpi_integer, mpi_comm_world, ierr)
1450  call pmc_mpi_check_ierr(ierr)
1451  recv = reshape(recv_buf, (/n_data, n_proc/))
1452  deallocate(send_buf)
1453  deallocate(recv_buf)
1454 #else
1455  recv(:, 1) = send
1456 #endif
1457 
1458  end subroutine pmc_mpi_allgather_integer_array
1459 
1460 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1461 
1462  !> Does an allgather of real arrays (must be the same size on all
1463  !> processes).
1464  subroutine pmc_mpi_allgather_real_array(send, recv)
1465 
1466  !> Values to send on each process.
1467  real(kind=dp), intent(in) :: send(:)
1468  !> Values to receive (will be the same on all processes.
1469  real(kind=dp), intent(out) :: recv(:,:)
1470 
1471 #ifdef PMC_USE_MPI
1472  integer :: n_proc, n_bin, n_data, ierr
1473  real(kind=dp), allocatable :: send_buf(:), recv_buf(:)
1474 
1475  n_proc = pmc_mpi_size()
1476  n_data = size(send, 1)
1477  call assert(291000580, all(shape(recv) == (/n_data, n_proc/)))
1478 
1479  ! use a new send_buf to make sure the memory is contiguous
1480  allocate(send_buf(n_data))
1481  allocate(recv_buf(n_data * n_proc))
1482  send_buf = send
1483  call mpi_allgather(send_buf, n_data, mpi_double_precision, &
1484  recv_buf, n_data, mpi_double_precision, mpi_comm_world, ierr)
1485  call pmc_mpi_check_ierr(ierr)
1486  recv = reshape(recv_buf, (/n_data, n_proc/))
1487  deallocate(send_buf)
1488  deallocate(recv_buf)
1489 #else
1490  recv(:, 1) = send
1491 #endif
1492 
1493  end subroutine pmc_mpi_allgather_real_array
1494 
1495 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1496 
1497  !> Unpacks the given value from the buffer to an allocated array, advancing
1498  !> position.
1499  subroutine pmc_mpi_unpack_real_array_alloc(buffer, position, val)
1500 
1501  !> Memory buffer.
1502  character, intent(inout) :: buffer(:)
1503  !> Current buffer position.
1504  integer, intent(inout) :: position
1505  !> Value to pack.
1506  real(kind=dp), intent(inout), allocatable :: val(:)
1507 
1508 #ifdef PMC_USE_MPI
1509  integer :: prev_position, n, ierr
1510 
1511  prev_position = position
1512  call pmc_mpi_unpack_integer(buffer, position, n)
1513  if (allocated(val)) deallocate(val)
1514  allocate(val(n))
1515  call mpi_unpack(buffer, size(buffer), position, val, n, &
1516  mpi_double_precision, mpi_comm_world, ierr)
1517  call pmc_mpi_check_ierr(ierr)
1518  call assert(520690818, &
1519  position - prev_position <= pmc_mpi_pack_size_real_array(val))
1520 #endif
1521 
1522  end subroutine pmc_mpi_unpack_real_array_alloc
1523 
1524 end module pmc_mpi
integer function pmc_mpi_pack_size_real(val)
Determines the number of bytes required to pack the given value.
Definition: mpi.F90:367
integer function pmc_mpi_pack_size_real_array(val)
Determines the number of bytes required to pack the given value.
Definition: mpi.F90:471
subroutine pmc_mpi_pack_logical(buffer, position, val)
Packs the given value into the buffer, advancing position.
Definition: mpi.F90:611
integer function pmc_mpi_pack_size_integer(val)
Determines the number of bytes required to pack the given value.
Definition: mpi.F90:347
subroutine pmc_mpi_transfer_real(from_val, to_val, from_proc, to_proc)
Transfer the value between the given processes.
Definition: mpi.F90:1038
subroutine pmc_mpi_pack_real_array_2d(buffer, position, val)
Packs the given value into the buffer, advancing position.
Definition: mpi.F90:742
subroutine pmc_mpi_allreduce_min_real(val, val_min)
Computes the minimum of val across all processes, storing the result in val_min on all processes...
Definition: mpi.F90:1313
subroutine pmc_mpi_bcast_string(val)
Broadcast the given value from process 0 to all other processes.
Definition: mpi.F90:309
subroutine pmc_mpi_unpack_real(buffer, position, val)
Unpacks the given value from the buffer, advancing position.
Definition: mpi.F90:796
character(len=pmc_util_convert_string_len) function logical_to_string(val)
Convert a logical to a string format.
Definition: util.F90:775
subroutine pmc_mpi_unpack_real_array_alloc(buffer, position, val)
Unpacks the given value from the buffer to an allocated array, advancing position.
Definition: mpi.F90:1499
subroutine pmc_mpi_allreduce_sum_integer(val, val_sum)
Computes the sum of val across all processes, storing the result in val_sum on all processes...
Definition: mpi.F90:1140
subroutine assert_msg(code, condition_ok, error_msg)
Errors unless condition_ok is true.
Definition: util.F90:76
subroutine pmc_mpi_bcast_packed(val)
Broadcast the given value from process 0 to all other processes.
Definition: mpi.F90:328
subroutine pmc_mpi_unpack_complex(buffer, position, val)
Unpacks the given value from the buffer, advancing position.
Definition: mpi.F90:874
subroutine pmc_mpi_pack_string(buffer, position, val)
Packs the given value into the buffer, advancing position.
Definition: mpi.F90:584
logical function pmc_mpi_allequal_real(val)
Returns whether all processors have the same value.
Definition: mpi.F90:1382
subroutine pmc_mpi_pack_string_array(buffer, position, val)
Packs the given value into the buffer, advancing position.
Definition: mpi.F90:715
integer function pmc_mpi_pack_size_string(val)
Determines the number of bytes required to pack the given value.
Definition: mpi.F90:387
subroutine pmc_mpi_finalize()
Shut down MPI.
Definition: mpi.F90:88
subroutine pmc_mpi_init()
Initialize MPI.
Definition: mpi.F90:55
subroutine pmc_mpi_pack_integer(buffer, position, val)
Packs the given value into the buffer, advancing position.
Definition: mpi.F90:534
subroutine pmc_mpi_reduce_avg_real_array(val, val_avg)
Computes the average of val across all processes, storing the result in val_avg on the root process...
Definition: mpi.F90:1163
integer function pmc_mpi_size()
Returns the total number of processes.
Definition: mpi.F90:133
subroutine pmc_mpi_reduce_sum_integer(val, val_sum)
Computes the sum of val across all processes, storing the result in val_sum on the root process...
Definition: mpi.F90:1117
subroutine pmc_mpi_test()
Perform basic sanity checks on send/receive.
Definition: mpi.F90:150
Common utility subroutines.
Definition: util.F90:9
subroutine pmc_mpi_unpack_real_array(buffer, position, val)
Unpacks the given value from the buffer, advancing position.
Definition: mpi.F90:927
logical function pmc_mpi_allequal_integer(val)
Returns whether all processors have the same value.
Definition: mpi.F90:1358
subroutine pmc_mpi_allreduce_average_real_array(val, val_avg)
Computes the average of val across all processes, storing the result in val_avg on all processes...
Definition: mpi.F90:1242
subroutine pmc_mpi_unpack_integer(buffer, position, val)
Unpacks the given value from the buffer, advancing position.
Definition: mpi.F90:771
integer function pmc_mpi_rank()
Returns the rank of the current process.
Definition: mpi.F90:116
Wrapper functions for MPI.
Definition: mpi.F90:13
subroutine pmc_mpi_bcast_integer(val)
Broadcast the given value from process 0 to all other processes.
Definition: mpi.F90:290
subroutine pmc_mpi_unpack_integer_array(buffer, position, val)
Unpacks the given value from the buffer, advancing position.
Definition: mpi.F90:899
integer function pmc_mpi_pack_size_real_array_2d(val)
Determines the number of bytes required to pack the given value.
Definition: mpi.F90:511
integer function pmc_mpi_pack_size_string_array(val)
Determines the number of bytes required to pack the given value.
Definition: mpi.F90:493
subroutine pmc_mpi_pack_complex(buffer, position, val)
Packs the given value into the buffer, advancing position.
Definition: mpi.F90:636
subroutine pmc_mpi_unpack_logical(buffer, position, val)
Unpacks the given value from the buffer, advancing position.
Definition: mpi.F90:849
subroutine pmc_mpi_allreduce_max_real(val, val_max)
Computes the maximum of val across all processes, storing the result in val_max on all processes...
Definition: mpi.F90:1336
character(len=pmc_util_convert_string_len) function integer_to_string(val)
Convert an integer to a string format.
Definition: util.F90:743
integer function pmc_mpi_pack_size_complex(val)
Determines the number of bytes required to pack the given value.
Definition: mpi.F90:429
character(len=pmc_util_convert_string_len) function complex_to_string(val)
Convert a complex to a string format.
Definition: util.F90:795
subroutine pmc_mpi_transfer_integer(from_val, to_val, from_proc, to_proc)
Transfer the value between the given processes.
Definition: mpi.F90:1077
logical function pmc_mpi_support()
Whether MPI support is compiled in.
Definition: mpi.F90:26
subroutine pmc_mpi_check_ierr(ierr)
Dies if ierr is not ok.
Definition: mpi.F90:39
subroutine pmc_mpi_unpack_real_array_2d(buffer, position, val)
Unpacks the given value from the buffer, advancing position.
Definition: mpi.F90:983
subroutine pmc_mpi_unpack_string(buffer, position, val)
Unpacks the given value from the buffer, advancing position.
Definition: mpi.F90:821
subroutine die(code)
Error immediately.
Definition: util.F90:121
subroutine pmc_mpi_abort(status)
Abort the program.
Definition: mpi.F90:70
subroutine pmc_mpi_barrier()
Synchronize all processes.
Definition: mpi.F90:102
subroutine pmc_mpi_pack_real(buffer, position, val)
Packs the given value into the buffer, advancing position.
Definition: mpi.F90:559
subroutine pmc_mpi_unpack_string_array(buffer, position, val)
Unpacks the given value from the buffer, advancing position.
Definition: mpi.F90:955
integer function pmc_mpi_pack_size_integer_array(val)
Determines the number of bytes required to pack the given value.
Definition: mpi.F90:449
subroutine pmc_mpi_pack_real_array(buffer, position, val)
Packs the given value into the buffer, advancing position.
Definition: mpi.F90:688
character(len=pmc_util_convert_string_len) function real_to_string(val)
Convert a real to a string format.
Definition: util.F90:759
subroutine pmc_mpi_allreduce_average_real(val, val_avg)
Computes the average of val across all processes, storing the result in val_avg on all processes...
Definition: mpi.F90:1218
subroutine pmc_mpi_alltoall_integer(send, recv)
Does an all-to-all transfer of integers.
Definition: mpi.F90:1406
subroutine pmc_mpi_allgather_real_array(send, recv)
Does an allgather of real arrays (must be the same size on all processes).
Definition: mpi.F90:1464
subroutine assert(code, condition_ok)
Errors unless condition_ok is true.
Definition: util.F90:102
subroutine pmc_mpi_reduce_avg_real(val, val_avg)
Computes the average of val across all processes, storing the result in val_avg on the root process...
Definition: mpi.F90:1013
subroutine pmc_mpi_allgather_integer_array(send, recv)
Does an allgather of integer arrays (must be the same size on all processes).
Definition: mpi.F90:1429
subroutine pmc_mpi_reduce_avg_real_array_2d(val, val_avg)
Computes the average of val across all processes, storing the result in val_avg on the root process...
Definition: mpi.F90:1190
subroutine pmc_mpi_pack_integer_array(buffer, position, val)
Packs the given value into the buffer, advancing position.
Definition: mpi.F90:661
subroutine pmc_mpi_allreduce_max_integer(val, val_max)
Computes the maximum of val across all processes, storing the result in val_max on all processes...
Definition: mpi.F90:1290
subroutine pmc_mpi_allreduce_min_integer(val, val_min)
Computes the minimum of val across all processes, storing the result in val_min on all processes...
Definition: mpi.F90:1267
integer function pmc_mpi_pack_size_logical(val)
Determines the number of bytes required to pack the given value.
Definition: mpi.F90:409