PartMC  2.2.0
mpi.F90
Go to the documentation of this file.
00001 ! Copyright (C) 2007-2011 Matthew West
00002 ! Licensed under the GNU General Public License version 2 or (at your
00003 ! option) any later version. See the file COPYING for details.
00004 
00005 !> \file
00006 !> The pmc_mpi module.
00007 
00008 !> Wrapper functions for MPI.
00009 !!
00010 !! All of these functions can be called irrespective of whether MPI
00011 !! support was compiled in or not. If MPI support is not enabled then
00012 !! they do the obvious trivial thing (normally nothing).
00013 module pmc_mpi
00014 
00015   use pmc_util
00016   
00017 #ifdef PMC_USE_MPI
00018   use mpi
00019 #endif
00020 
00021 contains
00022 
00023 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00024 
00025   !> Whether MPI support is compiled in.
00026   logical function pmc_mpi_support()
00027 
00028 #ifdef PMC_USE_MPI
00029     pmc_mpi_support = .true.
00030 #else
00031     pmc_mpi_support = .false.
00032 #endif
00033 
00034   end function pmc_mpi_support
00035 
00036 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00037 
00038   !> Dies if \c ierr is not ok.
00039   subroutine pmc_mpi_check_ierr(ierr)
00040 
00041     !> MPI status code.
00042     integer, intent(in) :: ierr
00043 
00044 #ifdef PMC_USE_MPI
00045     if (ierr /= MPI_SUCCESS) then
00046        call pmc_mpi_abort(1)
00047     end if
00048 #endif
00049 
00050   end subroutine pmc_mpi_check_ierr
00051 
00052 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00053 
00054   !> Initialize MPI.
00055   subroutine pmc_mpi_init()
00056 
00057 #ifdef PMC_USE_MPI
00058     integer :: ierr
00059 
00060     call mpi_init(ierr)
00061     call pmc_mpi_check_ierr(ierr)
00062     call pmc_mpi_test()
00063 #endif
00064 
00065   end subroutine pmc_mpi_init
00066 
00067 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00068 
00069   !> Abort the program.
00070   subroutine pmc_mpi_abort(status)
00071 
00072     !> Status flag to abort with.
00073     integer, intent(in) :: status
00074 
00075 #ifdef PMC_USE_MPI
00076     integer :: ierr
00077 
00078     call mpi_abort(MPI_COMM_WORLD, status, ierr)
00079 #else
00080     call die(status)
00081 #endif
00082 
00083   end subroutine pmc_mpi_abort
00084 
00085 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00086 
00087   !> Shut down MPI.
00088   subroutine pmc_mpi_finalize()
00089 
00090 #ifdef PMC_USE_MPI
00091     integer :: ierr
00092 
00093     call mpi_finalize(ierr)
00094     call pmc_mpi_check_ierr(ierr)
00095 #endif
00096 
00097   end subroutine pmc_mpi_finalize
00098 
00099 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00100 
00101   !> Synchronize all processes.
00102   subroutine pmc_mpi_barrier()
00103 
00104 #ifdef PMC_USE_MPI
00105     integer :: ierr
00106 
00107     call mpi_barrier(MPI_COMM_WORLD, ierr)
00108     call pmc_mpi_check_ierr(ierr)
00109 #endif
00110 
00111   end subroutine pmc_mpi_barrier
00112 
00113 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00114 
00115   !> Returns the rank of the current process.
00116   integer function pmc_mpi_rank()
00117 
00118 #ifdef PMC_USE_MPI
00119     integer :: rank, ierr
00120 
00121     call mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)
00122     call pmc_mpi_check_ierr(ierr)
00123     pmc_mpi_rank = rank
00124 #else
00125     pmc_mpi_rank = 0
00126 #endif
00127 
00128   end function pmc_mpi_rank
00129 
00130 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00131 
00132   !> Returns the total number of processes.
00133   integer function pmc_mpi_size()
00134 
00135 #ifdef PMC_USE_MPI
00136     integer :: size, ierr
00137 
00138     call mpi_comm_size(MPI_COMM_WORLD, size, ierr)
00139     call pmc_mpi_check_ierr(ierr)
00140     pmc_mpi_size = size
00141 #else
00142     pmc_mpi_size = 1
00143 #endif
00144 
00145   end function pmc_mpi_size
00146 
00147 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00148 
00149   !> Perform basic sanity checks on send/receive.
00150   subroutine pmc_mpi_test()
00151 
00152 #ifdef PMC_USE_MPI
00153     real(kind=dp), parameter :: test_real = 2.718281828459d0
00154     complex(kind=dc), parameter :: test_complex 
00155          = (0.707106781187d0, 1.4142135624d0)
00156     logical, parameter :: test_logical = .true.
00157     character(len=100), parameter :: test_string 
00158          = "a truth universally acknowledged"
00159     integer, parameter :: test_integer = 314159
00160 
00161     character, allocatable :: buffer(:)
00162     integer :: buffer_size, max_buffer_size, position
00163     real(kind=dp) :: send_real, recv_real
00164     complex(kind=dc) :: send_complex, recv_complex
00165     logical :: send_logical, recv_logical
00166     character(len=100) :: send_string, recv_string
00167     integer :: send_integer, recv_integer
00168     real(kind=dp) :: send_real_array(2)
00169     real(kind=dp), pointer :: recv_real_array(:)
00170 
00171     allocate(recv_real_array(1))
00172 
00173     if (pmc_mpi_rank() == 0) then
00174        send_real = test_real
00175        send_complex = test_complex
00176        send_logical = test_logical
00177        send_string = test_string
00178        send_integer = test_integer
00179        send_real_array(1) = real(test_complex)
00180        send_real_array(2) = aimag(test_complex)
00181 
00182        max_buffer_size = 0
00183        max_buffer_size = max_buffer_size &
00184             + pmc_mpi_pack_size_integer(send_integer)
00185        max_buffer_size = max_buffer_size &
00186             + pmc_mpi_pack_size_real(send_real)
00187        max_buffer_size = max_buffer_size &
00188             + pmc_mpi_pack_size_complex(send_complex)
00189        max_buffer_size = max_buffer_size &
00190             + pmc_mpi_pack_size_logical(send_logical)
00191        max_buffer_size = max_buffer_size &
00192             + pmc_mpi_pack_size_string(send_string)
00193        max_buffer_size = max_buffer_size &
00194             + pmc_mpi_pack_size_real_array(send_real_array)
00195 
00196        allocate(buffer(max_buffer_size))
00197 
00198        position = 0
00199        call pmc_mpi_pack_real(buffer, position, send_real)
00200        call pmc_mpi_pack_complex(buffer, position, send_complex)
00201        call pmc_mpi_pack_logical(buffer, position, send_logical)
00202        call pmc_mpi_pack_string(buffer, position, send_string)
00203        call pmc_mpi_pack_integer(buffer, position, send_integer)
00204        call pmc_mpi_pack_real_array(buffer, position, send_real_array)
00205        call assert_msg(350740830, position <= max_buffer_size, &
00206             "MPI test failure: pack position " &
00207             // trim(integer_to_string(position)) &
00208             // " greater than max_buffer_size " &
00209             // trim(integer_to_string(max_buffer_size)))
00210        buffer_size = position ! might be less than we allocated
00211     end if
00212 
00213     call pmc_mpi_bcast_integer(buffer_size)
00214 
00215     if (pmc_mpi_rank() /= 0) then
00216        allocate(buffer(buffer_size))
00217     end if
00218 
00219     call pmc_mpi_bcast_packed(buffer)
00220 
00221     if (pmc_mpi_rank() /= 0) then
00222        position = 0
00223        call pmc_mpi_unpack_real(buffer, position, recv_real)
00224        call pmc_mpi_unpack_complex(buffer, position, recv_complex)
00225        call pmc_mpi_unpack_logical(buffer, position, recv_logical)
00226        call pmc_mpi_unpack_string(buffer, position, recv_string)
00227        call pmc_mpi_unpack_integer(buffer, position, recv_integer)
00228        call pmc_mpi_unpack_real_array(buffer, position, recv_real_array)
00229        call assert_msg(787677020, position == buffer_size, &
00230             "MPI test failure: unpack position " &
00231             // trim(integer_to_string(position)) &
00232             // " not equal to buffer_size " &
00233             // trim(integer_to_string(buffer_size)))
00234     end if
00235 
00236     deallocate(buffer)
00237 
00238     if (pmc_mpi_rank() /= 0) then
00239        call assert_msg(567548916, recv_real == test_real, &
00240             "MPI test failure: real recv " &
00241             // trim(real_to_string(recv_real)) &
00242             // " not equal to " &
00243             // trim(real_to_string(test_real)))
00244        call assert_msg(653908509, recv_complex == test_complex, &
00245             "MPI test failure: complex recv " &
00246             // trim(complex_to_string(recv_complex)) &
00247             // " not equal to " &
00248             // trim(complex_to_string(test_complex)))
00249        call assert_msg(307746296, recv_logical .eqv. test_logical, &
00250             "MPI test failure: logical recv " &
00251             // trim(logical_to_string(recv_logical)) &
00252             // " not equal to " &
00253             // trim(logical_to_string(test_logical)))
00254        call assert_msg(155693492, recv_string == test_string, &
00255             "MPI test failure: string recv '" &
00256             // trim(recv_string) &
00257             // "' not equal to '" &
00258             // trim(test_string) // "'")
00259        call assert_msg(875699427, recv_integer == test_integer, &
00260             "MPI test failure: integer recv " &
00261             // trim(integer_to_string(recv_integer)) &
00262             // " not equal to " &
00263             // trim(integer_to_string(test_integer)))
00264        call assert_msg(326982363, size(recv_real_array) == 2, &
00265             "MPI test failure: real array recv size " &
00266             // trim(integer_to_string(size(recv_real_array))) &
00267             // " not equal to 2")
00268        call assert_msg(744394323, &
00269             recv_real_array(1) == real(test_complex), 
00270             "MPI test failure: real array recv index 1 " 
00271             // trim(real_to_string(recv_real_array(1))) 
00272             // " not equal to " 
00273             // trim(real_to_string(real(test_complex))))
00274        call assert_msg(858902527, &
00275             recv_real_array(2) == aimag(test_complex), &
00276             "MPI test failure: real array recv index 2 " &
00277             // trim(real_to_string(recv_real_array(2))) &
00278             // " not equal to " &
00279             // trim(real_to_string(aimag(test_complex))))
00280     end if
00281 
00282     deallocate(recv_real_array)
00283 #endif
00284 
00285   end subroutine pmc_mpi_test
00286 
00287 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00288 
00289   !> Broadcast the given value from process 0 to all other processes.
00290   subroutine pmc_mpi_bcast_integer(val)
00291 
00292     !> Value to broadcast.
00293     integer, intent(inout) :: val
00294 
00295 #ifdef PMC_USE_MPI
00296     integer :: root, ierr
00297 
00298     root = 0 ! source of data to broadcast
00299     call mpi_bcast(val, 1, MPI_INTEGER, root, &
00300          MPI_COMM_WORLD, ierr)
00301     call pmc_mpi_check_ierr(ierr)
00302 #endif
00303 
00304   end subroutine pmc_mpi_bcast_integer
00305 
00306 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00307 
00308   !> Broadcast the given value from process 0 to all other processes.
00309   subroutine pmc_mpi_bcast_string(val)
00310 
00311     !> Value to broadcast.
00312     character(len=*), intent(inout) :: val
00313 
00314 #ifdef PMC_USE_MPI
00315     integer :: root, ierr
00316 
00317     root = 0 ! source of data to broadcast
00318     call mpi_bcast(val, len(val), MPI_CHARACTER, root, &
00319          MPI_COMM_WORLD, ierr)
00320     call pmc_mpi_check_ierr(ierr)
00321 #endif
00322 
00323   end subroutine pmc_mpi_bcast_string
00324 
00325 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00326 
00327   !> Broadcast the given value from process 0 to all other processes.
00328   subroutine pmc_mpi_bcast_packed(val)
00329 
00330     !> Value to broadcast.
00331     character, intent(inout) :: val(:)
00332 
00333 #ifdef PMC_USE_MPI
00334     integer :: root, ierr
00335 
00336     root = 0 ! source of data to broadcast
00337     call mpi_bcast(val, size(val), MPI_CHARACTER, root, &
00338          MPI_COMM_WORLD, ierr)
00339     call pmc_mpi_check_ierr(ierr)
00340 #endif
00341 
00342   end subroutine pmc_mpi_bcast_packed
00343 
00344 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00345 
00346   !> Determines the number of bytes required to pack the given value.
00347   integer function pmc_mpi_pack_size_integer(val)
00348 
00349     !> Value to pack.
00350     integer, intent(in) :: val
00351 
00352     integer :: ierr
00353 
00354 #ifdef PMC_USE_MPI
00355     call mpi_pack_size(1, MPI_INTEGER, MPI_COMM_WORLD, &
00356          pmc_mpi_pack_size_integer, ierr)
00357     call pmc_mpi_check_ierr(ierr)
00358 #else
00359     pmc_mpi_pack_size_integer = 0
00360 #endif
00361 
00362   end function pmc_mpi_pack_size_integer
00363 
00364 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00365 
00366   !> Determines the number of bytes required to pack the given value.
00367   integer function pmc_mpi_pack_size_real(val)
00368 
00369     !> Value to pack.
00370     real(kind=dp), intent(in) :: val
00371 
00372     integer :: ierr
00373 
00374 #ifdef PMC_USE_MPI
00375     call mpi_pack_size(1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, &
00376          pmc_mpi_pack_size_real, ierr)
00377     call pmc_mpi_check_ierr(ierr)
00378 #else
00379     pmc_mpi_pack_size_real = 0
00380 #endif
00381 
00382   end function pmc_mpi_pack_size_real
00383 
00384 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00385 
00386   !> Determines the number of bytes required to pack the given value.
00387   integer function pmc_mpi_pack_size_string(val)
00388 
00389     !> Value to pack.
00390     character(len=*), intent(in) :: val
00391 
00392     integer :: ierr
00393 
00394 #ifdef PMC_USE_MPI
00395     call mpi_pack_size(len_trim(val), MPI_CHARACTER, MPI_COMM_WORLD, &
00396          pmc_mpi_pack_size_string, ierr)
00397     call pmc_mpi_check_ierr(ierr)
00398     pmc_mpi_pack_size_string = pmc_mpi_pack_size_string &
00399          + pmc_mpi_pack_size_integer(len_trim(val))
00400 #else
00401     pmc_mpi_pack_size_string = 0
00402 #endif
00403 
00404   end function pmc_mpi_pack_size_string
00405 
00406 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00407 
00408   !> Determines the number of bytes required to pack the given value.
00409   integer function pmc_mpi_pack_size_logical(val)
00410 
00411     !> Value to pack.
00412     logical, intent(in) :: val
00413 
00414     integer :: ierr
00415 
00416 #ifdef PMC_USE_MPI
00417     call mpi_pack_size(1, MPI_LOGICAL, MPI_COMM_WORLD, &
00418          pmc_mpi_pack_size_logical, ierr)
00419     call pmc_mpi_check_ierr(ierr)
00420 #else
00421     pmc_mpi_pack_size_logical = 0
00422 #endif
00423 
00424   end function pmc_mpi_pack_size_logical
00425 
00426 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00427 
00428   !> Determines the number of bytes required to pack the given value.
00429   integer function pmc_mpi_pack_size_complex(val)
00430 
00431     !> Value to pack.
00432     complex(kind=dc), intent(in) :: val
00433 
00434     integer :: ierr
00435 
00436 #ifdef PMC_USE_MPI
00437     call mpi_pack_size(1, MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, &
00438          pmc_mpi_pack_size_complex, ierr)
00439     call pmc_mpi_check_ierr(ierr)
00440 #else
00441     pmc_mpi_pack_size_complex = 0
00442 #endif
00443 
00444   end function pmc_mpi_pack_size_complex
00445 
00446 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00447 
00448   !> Determines the number of bytes required to pack the given value.
00449   integer function pmc_mpi_pack_size_integer_array(val)
00450 
00451     !> Value to pack.
00452     integer, intent(in) :: val(:)
00453 
00454     integer :: ierr
00455 
00456 #ifdef PMC_USE_MPI
00457     call mpi_pack_size(size(val), MPI_INTEGER, MPI_COMM_WORLD, &
00458          pmc_mpi_pack_size_integer_array, ierr)
00459     call pmc_mpi_check_ierr(ierr)
00460     pmc_mpi_pack_size_integer_array = pmc_mpi_pack_size_integer_array &
00461          + pmc_mpi_pack_size_integer(size(val))
00462 #else
00463     pmc_mpi_pack_size_integer_array = 0
00464 #endif
00465 
00466   end function pmc_mpi_pack_size_integer_array
00467 
00468 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00469 
00470   !> Determines the number of bytes required to pack the given value.
00471   integer function pmc_mpi_pack_size_real_array(val)
00472 
00473     !> Value to pack.
00474     real(kind=dp), intent(in) :: val(:)
00475 
00476     integer :: ierr
00477 
00478 #ifdef PMC_USE_MPI
00479     call mpi_pack_size(size(val), MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, &
00480          pmc_mpi_pack_size_real_array, ierr)
00481     call pmc_mpi_check_ierr(ierr)
00482     pmc_mpi_pack_size_real_array = pmc_mpi_pack_size_real_array &
00483          + pmc_mpi_pack_size_integer(size(val))
00484 #else
00485     pmc_mpi_pack_size_real_array = 0
00486 #endif
00487 
00488   end function pmc_mpi_pack_size_real_array
00489 
00490 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00491 
00492   !> Determines the number of bytes required to pack the given value.
00493   integer function pmc_mpi_pack_size_string_array(val)
00494 
00495     !> Value to pack.
00496     character(len=*), intent(in) :: val(:)
00497 
00498     integer :: i, total_size
00499 
00500     total_size = pmc_mpi_pack_size_integer(size(val))
00501     do i = 1,size(val)
00502        total_size = total_size + pmc_mpi_pack_size_string(val(i))
00503     end do
00504     pmc_mpi_pack_size_string_array = total_size
00505 
00506   end function pmc_mpi_pack_size_string_array
00507 
00508 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00509 
00510   !> Determines the number of bytes required to pack the given value.
00511   integer function pmc_mpi_pack_size_real_array_2d(val)
00512 
00513     !> Value to pack.
00514     real(kind=dp), intent(in) :: val(:,:)
00515 
00516     integer :: ierr
00517 
00518 #ifdef PMC_USE_MPI
00519     call mpi_pack_size(size(val), MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, &
00520          pmc_mpi_pack_size_real_array_2d, ierr)
00521     call pmc_mpi_check_ierr(ierr)
00522     pmc_mpi_pack_size_real_array_2d = pmc_mpi_pack_size_real_array_2d &
00523          + pmc_mpi_pack_size_integer(size(val,1)) &
00524          + pmc_mpi_pack_size_integer(size(val,2))
00525 #else
00526     pmc_mpi_pack_size_real_array_2d = 0
00527 #endif
00528 
00529   end function pmc_mpi_pack_size_real_array_2d
00530 
00531 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00532 
00533   !> Packs the given value into the buffer, advancing position.
00534   subroutine pmc_mpi_pack_integer(buffer, position, val)
00535 
00536     !> Memory buffer.
00537     character, intent(inout) :: buffer(:)
00538     !> Current buffer position.
00539     integer, intent(inout) :: position
00540     !> Value to pack.
00541     integer, intent(in) :: val
00542 
00543 #ifdef PMC_USE_MPI
00544     integer :: prev_position, ierr
00545 
00546     prev_position = position
00547     call mpi_pack(val, 1, MPI_INTEGER, buffer, size(buffer), &
00548          position, MPI_COMM_WORLD, ierr)
00549     call pmc_mpi_check_ierr(ierr)
00550     call assert(913495993, &
00551          position - prev_position <= pmc_mpi_pack_size_integer(val))
00552 #endif
00553 
00554   end subroutine pmc_mpi_pack_integer
00555 
00556 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00557 
00558   !> Packs the given value into the buffer, advancing position.
00559   subroutine pmc_mpi_pack_real(buffer, position, val)
00560 
00561     !> Memory buffer.
00562     character, intent(inout) :: buffer(:)
00563     !> Current buffer position.
00564     integer, intent(inout) :: position
00565     !> Value to pack.
00566     real(kind=dp), intent(in) :: val
00567 
00568 #ifdef PMC_USE_MPI
00569     integer :: prev_position, ierr
00570 
00571     prev_position = position
00572     call mpi_pack(val, 1, MPI_DOUBLE_PRECISION, buffer, size(buffer), &
00573          position, MPI_COMM_WORLD, ierr)
00574     call pmc_mpi_check_ierr(ierr)
00575     call assert(395354132, &
00576          position - prev_position <= pmc_mpi_pack_size_real(val))
00577 #endif
00578 
00579   end subroutine pmc_mpi_pack_real
00580 
00581 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00582 
00583   !> Packs the given value into the buffer, advancing position.
00584   subroutine pmc_mpi_pack_string(buffer, position, val)
00585 
00586     !> Memory buffer.
00587     character, intent(inout) :: buffer(:)
00588     !> Current buffer position.
00589     integer, intent(inout) :: position
00590     !> Value to pack.
00591     character(len=*), intent(in) :: val
00592 
00593 #ifdef PMC_USE_MPI
00594     integer :: prev_position, length, ierr
00595 
00596     prev_position = position
00597     length = len_trim(val)
00598     call pmc_mpi_pack_integer(buffer, position, length)
00599     call mpi_pack(val, length, MPI_CHARACTER, buffer, size(buffer), &
00600          position, MPI_COMM_WORLD, ierr)
00601     call pmc_mpi_check_ierr(ierr)
00602     call assert(607212018, &
00603          position - prev_position <= pmc_mpi_pack_size_string(val))
00604 #endif
00605 
00606   end subroutine pmc_mpi_pack_string
00607 
00608 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00609 
00610   !> Packs the given value into the buffer, advancing position.
00611   subroutine pmc_mpi_pack_logical(buffer, position, val)
00612 
00613     !> Memory buffer.
00614     character, intent(inout) :: buffer(:)
00615     !> Current buffer position.
00616     integer, intent(inout) :: position
00617     !> Value to pack.
00618     logical, intent(in) :: val
00619 
00620 #ifdef PMC_USE_MPI
00621     integer :: prev_position, ierr
00622 
00623     prev_position = position
00624     call mpi_pack(val, 1, MPI_LOGICAL, buffer, size(buffer), &
00625          position, MPI_COMM_WORLD, ierr)
00626     call pmc_mpi_check_ierr(ierr)
00627     call assert(104535200, &
00628          position - prev_position <= pmc_mpi_pack_size_logical(val))
00629 #endif
00630 
00631   end subroutine pmc_mpi_pack_logical
00632 
00633 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00634 
00635   !> Packs the given value into the buffer, advancing position.
00636   subroutine pmc_mpi_pack_complex(buffer, position, val)
00637 
00638     !> Memory buffer.
00639     character, intent(inout) :: buffer(:)
00640     !> Current buffer position.
00641     integer, intent(inout) :: position
00642     !> Value to pack.
00643     complex(kind=dc), intent(in) :: val
00644 
00645 #ifdef PMC_USE_MPI
00646     integer :: prev_position, ierr
00647 
00648     prev_position = position
00649     call mpi_pack(val, 1, MPI_DOUBLE_COMPLEX, buffer, size(buffer), &
00650          position, MPI_COMM_WORLD, ierr)
00651     call pmc_mpi_check_ierr(ierr)
00652     call assert(640416372, &
00653          position - prev_position <= pmc_mpi_pack_size_complex(val))
00654 #endif
00655 
00656   end subroutine pmc_mpi_pack_complex
00657 
00658 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00659 
00660   !> Packs the given value into the buffer, advancing position.
00661   subroutine pmc_mpi_pack_integer_array(buffer, position, val)
00662 
00663     !> Memory buffer.
00664     character, intent(inout) :: buffer(:)
00665     !> Current buffer position.
00666     integer, intent(inout) :: position
00667     !> Value to pack.
00668     integer, intent(in) :: val(:)
00669 
00670 #ifdef PMC_USE_MPI
00671     integer :: prev_position, n, ierr
00672 
00673     prev_position = position
00674     n = size(val)
00675     call pmc_mpi_pack_integer(buffer, position, n)
00676     call mpi_pack(val, n, MPI_INTEGER, buffer, size(buffer), &
00677          position, MPI_COMM_WORLD, ierr)
00678     call pmc_mpi_check_ierr(ierr)
00679     call assert(698601296, &
00680          position - prev_position <= pmc_mpi_pack_size_integer_array(val))
00681 #endif
00682 
00683   end subroutine pmc_mpi_pack_integer_array
00684 
00685 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00686 
00687   !> Packs the given value into the buffer, advancing position.
00688   subroutine pmc_mpi_pack_real_array(buffer, position, val)
00689 
00690     !> Memory buffer.
00691     character, intent(inout) :: buffer(:)
00692     !> Current buffer position.
00693     integer, intent(inout) :: position
00694     !> Value to pack.
00695     real(kind=dp), intent(in) :: val(:)
00696 
00697 #ifdef PMC_USE_MPI
00698     integer :: prev_position, n, ierr
00699 
00700     prev_position = position
00701     n = size(val)
00702     call pmc_mpi_pack_integer(buffer, position, n)
00703     call mpi_pack(val, n, MPI_DOUBLE_PRECISION, buffer, size(buffer), &
00704          position, MPI_COMM_WORLD, ierr)
00705     call pmc_mpi_check_ierr(ierr)
00706     call assert(825718791, &
00707          position - prev_position <= pmc_mpi_pack_size_real_array(val))
00708 #endif
00709 
00710   end subroutine pmc_mpi_pack_real_array
00711 
00712 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00713 
00714   !> Packs the given value into the buffer, advancing position.
00715   subroutine pmc_mpi_pack_string_array(buffer, position, val)
00716 
00717     !> Memory buffer.
00718     character, intent(inout) :: buffer(:)
00719     !> Current buffer position.
00720     integer, intent(inout) :: position
00721     !> Value to pack.
00722     character(len=*), intent(in) :: val(:)
00723 
00724 #ifdef PMC_USE_MPI
00725     integer :: prev_position, i, n
00726 
00727     prev_position = position
00728     n = size(val)
00729     call pmc_mpi_pack_integer(buffer, position, n)
00730     do i = 1,n
00731        call pmc_mpi_pack_string(buffer, position, val(i))
00732     end do
00733     call assert(630900704, &
00734          position - prev_position <= pmc_mpi_pack_size_string_array(val))
00735 #endif
00736 
00737   end subroutine pmc_mpi_pack_string_array
00738 
00739 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00740 
00741   !> Packs the given value into the buffer, advancing position.
00742   subroutine pmc_mpi_pack_real_array_2d(buffer, position, val)
00743 
00744     !> Memory buffer.
00745     character, intent(inout) :: buffer(:)
00746     !> Current buffer position.
00747     integer, intent(inout) :: position
00748     !> Value to pack.
00749     real(kind=dp), intent(in) :: val(:,:)
00750 
00751 #ifdef PMC_USE_MPI
00752     integer :: prev_position, n1, n2, ierr
00753 
00754     prev_position = position
00755     n1 = size(val, 1)
00756     n2 = size(val, 2)
00757     call pmc_mpi_pack_integer(buffer, position, n1)
00758     call pmc_mpi_pack_integer(buffer, position, n2)
00759     call mpi_pack(val, n1*n2, MPI_DOUBLE_PRECISION, buffer, size(buffer), &
00760          position, MPI_COMM_WORLD, ierr)
00761     call pmc_mpi_check_ierr(ierr)
00762     call assert(567349745, &
00763          position - prev_position <= pmc_mpi_pack_size_real_array_2d(val))
00764 #endif
00765 
00766   end subroutine pmc_mpi_pack_real_array_2d
00767 
00768 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00769 
00770   !> Unpacks the given value from the buffer, advancing position.
00771   subroutine pmc_mpi_unpack_integer(buffer, position, val)
00772 
00773     !> Memory buffer.
00774     character, intent(inout) :: buffer(:)
00775     !> Current buffer position.
00776     integer, intent(inout) :: position
00777     !> Value to pack.
00778     integer, intent(out) :: val
00779 
00780 #ifdef PMC_USE_MPI
00781     integer :: prev_position, ierr
00782 
00783     prev_position = position
00784     call mpi_unpack(buffer, size(buffer), position, val, 1, MPI_INTEGER, &
00785          MPI_COMM_WORLD, ierr)
00786     call pmc_mpi_check_ierr(ierr)
00787     call assert(890243339, &
00788          position - prev_position <= pmc_mpi_pack_size_integer(val))
00789 #endif
00790 
00791   end subroutine pmc_mpi_unpack_integer
00792 
00793 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00794 
00795   !> Unpacks the given value from the buffer, advancing position.
00796   subroutine pmc_mpi_unpack_real(buffer, position, val)
00797 
00798     !> Memory buffer.
00799     character, intent(inout) :: buffer(:)
00800     !> Current buffer position.
00801     integer, intent(inout) :: position
00802     !> Value to pack.
00803     real(kind=dp), intent(out) :: val
00804 
00805 #ifdef PMC_USE_MPI
00806     integer :: prev_position, ierr
00807 
00808     prev_position = position
00809     call mpi_unpack(buffer, size(buffer), position, val, 1, &
00810          MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
00811     call pmc_mpi_check_ierr(ierr)
00812     call assert(570771632, &
00813          position - prev_position <= pmc_mpi_pack_size_real(val))
00814 #endif
00815 
00816   end subroutine pmc_mpi_unpack_real
00817 
00818 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00819 
00820   !> Unpacks the given value from the buffer, advancing position.
00821   subroutine pmc_mpi_unpack_string(buffer, position, val)
00822 
00823     !> Memory buffer.
00824     character, intent(inout) :: buffer(:)
00825     !> Current buffer position.
00826     integer, intent(inout) :: position
00827     !> Value to pack.
00828     character(len=*), intent(out) :: val
00829 
00830 #ifdef PMC_USE_MPI
00831     integer :: prev_position, length, ierr
00832 
00833     prev_position = position
00834     call pmc_mpi_unpack_integer(buffer, position, length)
00835     call assert(946399479, length <= len(val))
00836     val = ''
00837     call mpi_unpack(buffer, size(buffer), position, val, length, &
00838          MPI_CHARACTER, MPI_COMM_WORLD, ierr)
00839     call pmc_mpi_check_ierr(ierr)
00840     call assert(503378058, &
00841          position - prev_position <= pmc_mpi_pack_size_string(val))
00842 #endif
00843 
00844   end subroutine pmc_mpi_unpack_string
00845 
00846 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00847 
00848   !> Unpacks the given value from the buffer, advancing position.
00849   subroutine pmc_mpi_unpack_logical(buffer, position, val)
00850 
00851     !> Memory buffer.
00852     character, intent(inout) :: buffer(:)
00853     !> Current buffer position.
00854     integer, intent(inout) :: position
00855     !> Value to pack.
00856     logical, intent(out) :: val
00857 
00858 #ifdef PMC_USE_MPI
00859     integer :: prev_position, ierr
00860 
00861     prev_position = position
00862     call mpi_unpack(buffer, size(buffer), position, val, 1, MPI_LOGICAL, &
00863          MPI_COMM_WORLD, ierr)
00864     call pmc_mpi_check_ierr(ierr)
00865     call assert(694750528, &
00866          position - prev_position <= pmc_mpi_pack_size_logical(val))
00867 #endif
00868 
00869   end subroutine pmc_mpi_unpack_logical
00870 
00871 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00872 
00873   !> Unpacks the given value from the buffer, advancing position.
00874   subroutine pmc_mpi_unpack_complex(buffer, position, val)
00875 
00876     !> Memory buffer.
00877     character, intent(inout) :: buffer(:)
00878     !> Current buffer position.
00879     integer, intent(inout) :: position
00880     !> Value to pack.
00881     complex(kind=dc), intent(out) :: val
00882 
00883 #ifdef PMC_USE_MPI
00884     integer :: prev_position, ierr
00885 
00886     prev_position = position
00887     call mpi_unpack(buffer, size(buffer), position, val, 1, &
00888          MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr)
00889     call pmc_mpi_check_ierr(ierr)
00890     call assert(969672634, &
00891          position - prev_position <= pmc_mpi_pack_size_complex(val))
00892 #endif
00893 
00894   end subroutine pmc_mpi_unpack_complex
00895 
00896 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00897 
00898   !> Unpacks the given value from the buffer, advancing position.
00899   subroutine pmc_mpi_unpack_integer_array(buffer, position, val)
00900 
00901     !> Memory buffer.
00902     character, intent(inout) :: buffer(:)
00903     !> Current buffer position.
00904     integer, intent(inout) :: position
00905     !> Value to pack.
00906     integer, pointer :: val(:)
00907 
00908 #ifdef PMC_USE_MPI
00909     integer :: prev_position, n, ierr
00910 
00911     prev_position = position
00912     call pmc_mpi_unpack_integer(buffer, position, n)
00913     deallocate(val)
00914     allocate(val(n))
00915     call mpi_unpack(buffer, size(buffer), position, val, n, MPI_INTEGER, &
00916          MPI_COMM_WORLD, ierr)
00917     call pmc_mpi_check_ierr(ierr)
00918     call assert(565840919, &
00919          position - prev_position <= pmc_mpi_pack_size_integer_array(val))
00920 #endif
00921 
00922   end subroutine pmc_mpi_unpack_integer_array
00923 
00924 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00925 
00926   !> Unpacks the given value from the buffer, advancing position.
00927   subroutine pmc_mpi_unpack_real_array(buffer, position, val)
00928 
00929     !> Memory buffer.
00930     character, intent(inout) :: buffer(:)
00931     !> Current buffer position.
00932     integer, intent(inout) :: position
00933     !> Value to pack.
00934     real(kind=dp), pointer :: val(:)
00935 
00936 #ifdef PMC_USE_MPI
00937     integer :: prev_position, n, ierr
00938 
00939     prev_position = position
00940     call pmc_mpi_unpack_integer(buffer, position, n)
00941     deallocate(val)
00942     allocate(val(n))
00943     call mpi_unpack(buffer, size(buffer), position, val, n, &
00944          MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
00945     call pmc_mpi_check_ierr(ierr)
00946     call assert(782875761, &
00947          position - prev_position <= pmc_mpi_pack_size_real_array(val))
00948 #endif
00949 
00950   end subroutine pmc_mpi_unpack_real_array
00951 
00952 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00953 
00954   !> Unpacks the given value from the buffer, advancing position.
00955   subroutine pmc_mpi_unpack_string_array(buffer, position, val)
00956 
00957     !> Memory buffer.
00958     character, intent(inout) :: buffer(:)
00959     !> Current buffer position.
00960     integer, intent(inout) :: position
00961     !> Value to pack.
00962     character(len=*), pointer :: val(:)
00963 
00964 #ifdef PMC_USE_MPI
00965     integer :: prev_position, i, n
00966 
00967     prev_position = position
00968     call pmc_mpi_unpack_integer(buffer, position, n)
00969     deallocate(val)
00970     allocate(val(n))
00971     do i = 1,n
00972        call pmc_mpi_unpack_string(buffer, position, val(i))
00973     end do
00974     call assert(320065648, &
00975          position - prev_position <= pmc_mpi_pack_size_string_array(val))
00976 #endif
00977 
00978   end subroutine pmc_mpi_unpack_string_array
00979 
00980 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
00981 
00982   !> Unpacks the given value from the buffer, advancing position.
00983   subroutine pmc_mpi_unpack_real_array_2d(buffer, position, val)
00984 
00985     !> Memory buffer.
00986     character, intent(inout) :: buffer(:)
00987     !> Current buffer position.
00988     integer, intent(inout) :: position
00989     !> Value to pack.
00990     real(kind=dp), pointer :: val(:,:)
00991 
00992 #ifdef PMC_USE_MPI
00993     integer :: prev_position, n1, n2, ierr
00994 
00995     prev_position = position
00996     call pmc_mpi_unpack_integer(buffer, position, n1)
00997     call pmc_mpi_unpack_integer(buffer, position, n2)
00998     deallocate(val)
00999     allocate(val(n1,n2))
01000     call mpi_unpack(buffer, size(buffer), position, val, n1*n2, &
01001          MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
01002     call pmc_mpi_check_ierr(ierr)
01003     call assert(781681739, position - prev_position &
01004          <= pmc_mpi_pack_size_real_array_2d(val))
01005 #endif
01006 
01007   end subroutine pmc_mpi_unpack_real_array_2d
01008 
01009 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01010 
01011   !> Computes the average of val across all processes, storing the
01012   !> result in val_avg on the root process.
01013   subroutine pmc_mpi_reduce_avg_real(val, val_avg)
01014 
01015     !> Value to average.
01016     real(kind=dp), intent(in) :: val
01017     !> Result.
01018     real(kind=dp), intent(out) :: val_avg
01019 
01020 #ifdef PMC_USE_MPI
01021     integer :: ierr
01022 
01023     call mpi_reduce(val, val_avg, 1, MPI_DOUBLE_PRECISION, MPI_SUM, 0, &
01024          MPI_COMM_WORLD, ierr)
01025     call pmc_mpi_check_ierr(ierr)
01026     if (pmc_mpi_rank() == 0) then
01027        val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
01028     end if
01029 #else
01030     val_avg = val
01031 #endif
01032 
01033   end subroutine pmc_mpi_reduce_avg_real
01034 
01035 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01036 
01037   !> Transfer the value between the given processes.
01038   subroutine pmc_mpi_transfer_real(from_val, to_val, from_proc, to_proc)
01039 
01040     !> Value to send.
01041     real(kind=dp), intent(in) :: from_val
01042     !> Variable to send to.
01043     real(kind=dp), intent(out) :: to_val
01044     !> Process to send from.
01045     integer, intent(in) :: from_proc
01046     !> Process to send to.
01047     integer, intent(in) :: to_proc
01048 
01049 #ifdef PMC_USE_MPI
01050     integer :: rank, ierr, status(MPI_STATUS_SIZE)
01051 
01052     rank = pmc_mpi_rank()
01053     if (from_proc == to_proc) then
01054        if (rank == from_proc) then
01055           to_val = from_val
01056        end if
01057     else
01058        if (rank == from_proc) then
01059           call mpi_send(from_val, 1, MPI_DOUBLE_PRECISION, to_proc, &
01060                208020430, MPI_COMM_WORLD, ierr)
01061           call pmc_mpi_check_ierr(ierr)
01062        elseif (rank == to_proc) then
01063           call mpi_recv(to_val, 1, MPI_DOUBLE_PRECISION, from_proc, &
01064                208020430, MPI_COMM_WORLD, status, ierr)
01065           call pmc_mpi_check_ierr(ierr)
01066        end if
01067     end if
01068 #else
01069     to_val = from_val
01070 #endif
01071 
01072   end subroutine pmc_mpi_transfer_real
01073 
01074 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01075 
01076   !> Transfer the value between the given processes.
01077   subroutine pmc_mpi_transfer_integer(from_val, to_val, from_proc, to_proc)
01078 
01079     !> Value to send.
01080     integer, intent(in) :: from_val
01081     !> Variable to send to.
01082     integer, intent(out) :: to_val
01083     !> Process to send from.
01084     integer, intent(in) :: from_proc
01085     !> Process to send to.
01086     integer, intent(in) :: to_proc
01087 
01088 #ifdef PMC_USE_MPI
01089     integer :: rank, ierr, status(MPI_STATUS_SIZE)
01090     
01091     rank = pmc_mpi_rank()
01092     if (from_proc == to_proc) then
01093        if (rank == from_proc) then
01094           to_val = from_val
01095        end if
01096     else
01097        if (rank == from_proc) then
01098           call mpi_send(from_val, 1, MPI_INTEGER, to_proc, &
01099                208020430, MPI_COMM_WORLD, ierr)
01100           call pmc_mpi_check_ierr(ierr)
01101        elseif (rank == to_proc) then
01102           call mpi_recv(to_val, 1, MPI_INTEGER, from_proc, &
01103                208020430, MPI_COMM_WORLD, status, ierr)
01104           call pmc_mpi_check_ierr(ierr)
01105        end if
01106     end if
01107 #else
01108     to_val = from_val
01109 #endif
01110 
01111   end subroutine pmc_mpi_transfer_integer
01112 
01113 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01114 
01115   !> Computes the sum of \c val across all processes, storing the
01116   !> result in \c val_sum on the root process.
01117   subroutine pmc_mpi_reduce_sum_integer(val, val_sum)
01118 
01119     !> Value to sum.
01120     integer, intent(in) :: val
01121     !> Result.
01122     integer, intent(out) :: val_sum
01123 
01124 #ifdef PMC_USE_MPI
01125     integer :: ierr
01126 
01127     call mpi_reduce(val, val_sum, 1, MPI_INTEGER, MPI_SUM, 0, &
01128          MPI_COMM_WORLD, ierr)
01129     call pmc_mpi_check_ierr(ierr)
01130 #else
01131     val_sum = val
01132 #endif
01133 
01134   end subroutine pmc_mpi_reduce_sum_integer
01135 
01136 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01137 
01138   !> Computes the sum of \c val across all processes, storing the
01139   !> result in \c val_sum on all processes.
01140   subroutine pmc_mpi_allreduce_sum_integer(val, val_sum)
01141 
01142     !> Value to sum.
01143     integer, intent(in) :: val
01144     !> Result.
01145     integer, intent(out) :: val_sum
01146 
01147 #ifdef PMC_USE_MPI
01148     integer :: ierr
01149 
01150     call mpi_allreduce(val, val_sum, 1, MPI_INTEGER, MPI_SUM, &
01151          MPI_COMM_WORLD, ierr)
01152     call pmc_mpi_check_ierr(ierr)
01153 #else
01154     val_sum = val
01155 #endif
01156 
01157   end subroutine pmc_mpi_allreduce_sum_integer
01158 
01159 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01160 
01161   !> Computes the average of val across all processes, storing the
01162   !> result in val_avg on the root process.
01163   subroutine pmc_mpi_reduce_avg_real_array(val, val_avg)
01164 
01165     !> Value to average.
01166     real(kind=dp), intent(in) :: val(:)
01167     !> Result.
01168     real(kind=dp), intent(out) :: val_avg(:)
01169 
01170 #ifdef PMC_USE_MPI
01171     integer :: ierr
01172 
01173     call assert(915136121, size(val) == size(val_avg))
01174     call mpi_reduce(val, val_avg, size(val), MPI_DOUBLE_PRECISION, &
01175          MPI_SUM, 0, MPI_COMM_WORLD, ierr)
01176     call pmc_mpi_check_ierr(ierr)
01177     if (pmc_mpi_rank() == 0) then
01178        val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
01179     end if
01180 #else
01181     val_avg = val
01182 #endif
01183 
01184   end subroutine pmc_mpi_reduce_avg_real_array
01185 
01186 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01187 
01188   !> Computes the average of val across all processes, storing the
01189   !> result in val_avg on the root process.
01190   subroutine pmc_mpi_reduce_avg_real_array_2d(val, val_avg)
01191 
01192     !> Value to average.
01193     real(kind=dp), intent(in) :: val(:,:)
01194     !> Result.
01195     real(kind=dp), intent(out) :: val_avg(:,:)
01196 
01197 #ifdef PMC_USE_MPI
01198     integer :: ierr
01199 
01200     call assert(131229046, size(val,1) == size(val_avg,1))
01201     call assert(992122167, size(val,2) == size(val_avg,2))
01202     call mpi_reduce(val, val_avg, size(val), MPI_DOUBLE_PRECISION, &
01203          MPI_SUM, 0, MPI_COMM_WORLD, ierr)
01204     call pmc_mpi_check_ierr(ierr)
01205     if (pmc_mpi_rank() == 0) then
01206        val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
01207     end if
01208 #else
01209     val_avg = val
01210 #endif
01211 
01212   end subroutine pmc_mpi_reduce_avg_real_array_2d
01213 
01214 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01215 
01216   !> Computes the average of val across all processes, storing the
01217   !> result in val_avg on all processes.
01218   subroutine pmc_mpi_allreduce_average_real(val, val_avg)
01219 
01220     !> Value to average.
01221     real(kind=dp), intent(in) :: val
01222     !> Result.
01223     real(kind=dp), intent(out) :: val_avg
01224 
01225 #ifdef PMC_USE_MPI
01226     integer :: ierr
01227 
01228     call mpi_allreduce(val, val_avg, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
01229          MPI_COMM_WORLD, ierr)
01230     call pmc_mpi_check_ierr(ierr)
01231     val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
01232 #else
01233     val_avg = val
01234 #endif
01235 
01236   end subroutine pmc_mpi_allreduce_average_real
01237 
01238 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01239 
01240   !> Computes the average of val across all processes, storing the
01241   !> result in val_avg on all processes.
01242   subroutine pmc_mpi_allreduce_average_real_array(val, val_avg)
01243 
01244     !> Value to average.
01245     real(kind=dp), intent(in) :: val(:)
01246     !> Result.
01247     real(kind=dp), intent(out) :: val_avg(:)
01248 
01249 #ifdef PMC_USE_MPI
01250     integer :: ierr
01251 
01252     call assert(948533359, size(val) == size(val_avg))
01253     call mpi_allreduce(val, val_avg, size(val), MPI_DOUBLE_PRECISION, &
01254          MPI_SUM, MPI_COMM_WORLD, ierr)
01255     call pmc_mpi_check_ierr(ierr)
01256     val_avg = val_avg / real(pmc_mpi_size(), kind=dp)
01257 #else
01258     val_avg = val
01259 #endif
01260 
01261   end subroutine pmc_mpi_allreduce_average_real_array
01262 
01263 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01264 
01265   !> Computes the minimum of val across all processes, storing the
01266   !> result in val_min on all processes.
01267   subroutine pmc_mpi_allreduce_min_integer(val, val_min)
01268 
01269     !> Value to minimize.
01270     integer, intent(in) :: val
01271     !> Result.
01272     integer, intent(out) :: val_min
01273 
01274 #ifdef PMC_USE_MPI
01275     integer :: ierr
01276 
01277     call mpi_allreduce(val, val_min, 1, MPI_INTEGER, MPI_MIN, &
01278          MPI_COMM_WORLD, ierr)
01279     call pmc_mpi_check_ierr(ierr)
01280 #else
01281     val_min = val
01282 #endif
01283 
01284   end subroutine pmc_mpi_allreduce_min_integer
01285 
01286 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01287 
01288   !> Computes the maximum of val across all processes, storing the
01289   !> result in val_max on all processes.
01290   subroutine pmc_mpi_allreduce_max_integer(val, val_max)
01291 
01292     !> Value to maximize.
01293     integer, intent(in) :: val
01294     !> Result.
01295     integer, intent(out) :: val_max
01296 
01297 #ifdef PMC_USE_MPI
01298     integer :: ierr
01299 
01300     call mpi_allreduce(val, val_max, 1, MPI_INTEGER, MPI_MAX, &
01301          MPI_COMM_WORLD, ierr)
01302     call pmc_mpi_check_ierr(ierr)
01303 #else
01304     val_max = val
01305 #endif
01306 
01307   end subroutine pmc_mpi_allreduce_max_integer
01308 
01309 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01310 
01311   !> Computes the minimum of val across all processes, storing the
01312   !> result in val_min on all processes.
01313   subroutine pmc_mpi_allreduce_min_real(val, val_min)
01314 
01315     !> Value to minimize.
01316     real(kind=dp), intent(in) :: val
01317     !> Result.
01318     real(kind=dp), intent(out) :: val_min
01319 
01320 #ifdef PMC_USE_MPI
01321     integer :: ierr
01322 
01323     call mpi_allreduce(val, val_min, 1, MPI_DOUBLE_PRECISION, MPI_MIN, &
01324          MPI_COMM_WORLD, ierr)
01325     call pmc_mpi_check_ierr(ierr)
01326 #else
01327     val_min = val
01328 #endif
01329 
01330   end subroutine pmc_mpi_allreduce_min_real
01331 
01332 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01333 
01334   !> Computes the maximum of val across all processes, storing the
01335   !> result in val_max on all processes.
01336   subroutine pmc_mpi_allreduce_max_real(val, val_max)
01337 
01338     !> Value to maximize.
01339     real(kind=dp), intent(in) :: val
01340     !> Result.
01341     real(kind=dp), intent(out) :: val_max
01342 
01343 #ifdef PMC_USE_MPI
01344     integer :: ierr
01345 
01346     call mpi_allreduce(val, val_max, 1, MPI_DOUBLE_PRECISION, MPI_MAX, &
01347          MPI_COMM_WORLD, ierr)
01348     call pmc_mpi_check_ierr(ierr)
01349 #else
01350     val_max = val
01351 #endif
01352 
01353   end subroutine pmc_mpi_allreduce_max_real
01354 
01355 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01356 
01357   !> Returns whether all processors have the same value.
01358   logical function pmc_mpi_allequal_integer(val)
01359 
01360     !> Value to compare.
01361     integer, intent(in) :: val
01362 
01363 #ifdef PMC_USE_MPI
01364     integer :: min_val, max_val
01365 
01366     call pmc_mpi_allreduce_min_integer(val, min_val)
01367     call pmc_mpi_allreduce_max_integer(val, max_val)
01368     if (min_val == max_val) then
01369        pmc_mpi_allequal_integer = .true.
01370     else
01371        pmc_mpi_allequal_integer = .false.
01372     end if
01373 #else
01374     pmc_mpi_allequal_integer = .true.
01375 #endif
01376 
01377   end function pmc_mpi_allequal_integer
01378 
01379 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01380 
01381   !> Returns whether all processors have the same value.
01382   logical function pmc_mpi_allequal_real(val)
01383 
01384     !> Value to compare.
01385     real(kind=dp), intent(in) :: val
01386 
01387 #ifdef PMC_USE_MPI
01388     real(kind=dp) :: min_val, max_val
01389 
01390     call pmc_mpi_allreduce_min_real(val, min_val)
01391     call pmc_mpi_allreduce_max_real(val, max_val)
01392     if (min_val == max_val) then
01393        pmc_mpi_allequal_real = .true.
01394     else
01395        pmc_mpi_allequal_real = .false.
01396     end if
01397 #else
01398     pmc_mpi_allequal_real = .true.
01399 #endif
01400 
01401   end function pmc_mpi_allequal_real
01402 
01403 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01404 
01405   !> Does an all-to-all transfer of integers.
01406   subroutine pmc_mpi_alltoall_integer(send, recv)
01407 
01408     !> Values to send (must be one per process).
01409     integer, intent(in) :: send(:)
01410     !> Values to receive (must be one per process).
01411     integer, intent(out) :: recv(size(send))
01412 
01413 #ifdef PMC_USE_MPI
01414     integer :: ierr
01415 
01416     call mpi_alltoall(send, 1, MPI_INTEGER, recv, 1, MPI_INTEGER, &
01417          MPI_COMM_WORLD, ierr)
01418     call pmc_mpi_check_ierr(ierr)
01419 #else
01420     recv = send
01421 #endif
01422 
01423   end subroutine pmc_mpi_alltoall_integer
01424 
01425 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01426 
01427   !> Does an allgather of integer arrays (must be the same size on all
01428   !> processes).
01429   subroutine pmc_mpi_allgather_integer_array(send, recv)
01430 
01431     !> Values to send on each process.
01432     integer, intent(in) :: send(:)
01433     !> Values to receive (will be the same on all processes.
01434     integer, intent(out) :: recv(:,:)
01435 
01436 #ifdef PMC_USE_MPI
01437     integer :: n_proc, n_bin, n_data, ierr
01438     integer, allocatable :: send_buf(:), recv_buf(:)
01439 
01440     n_proc = pmc_mpi_size()
01441     n_data = size(send, 1)
01442     call assert(291000580, all(shape(recv) == (/n_data, n_proc/)))
01443     
01444     ! use a new send_buf to make sure the memory is contiguous
01445     allocate(send_buf(n_data))
01446     allocate(recv_buf(n_data * n_proc))
01447     send_buf = send
01448     call mpi_allgather(send_buf, n_data, MPI_INTEGER, &
01449          recv_buf, n_data, MPI_INTEGER, MPI_COMM_WORLD, ierr)
01450     call pmc_mpi_check_ierr(ierr)
01451     recv = reshape(recv_buf, (/n_data, n_proc/))
01452     deallocate(send_buf)
01453     deallocate(recv_buf)
01454 #else
01455     recv(:, 1) = send
01456 #endif
01457 
01458   end subroutine pmc_mpi_allgather_integer_array
01459 
01460 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01461 
01462   !> Does an allgather of real arrays (must be the same size on all
01463   !> processes).
01464   subroutine pmc_mpi_allgather_real_array(send, recv)
01465 
01466     !> Values to send on each process.
01467     real(kind=dp), intent(in) :: send(:)
01468     !> Values to receive (will be the same on all processes.
01469     real(kind=dp), intent(out) :: recv(:,:)
01470 
01471 #ifdef PMC_USE_MPI
01472     integer :: n_proc, n_bin, n_data, ierr
01473     real(kind=dp), allocatable :: send_buf(:), recv_buf(:)
01474 
01475     n_proc = pmc_mpi_size()
01476     n_data = size(send, 1)
01477     call assert(291000580, all(shape(recv) == (/n_data, n_proc/)))
01478     
01479     ! use a new send_buf to make sure the memory is contiguous
01480     allocate(send_buf(n_data))
01481     allocate(recv_buf(n_data * n_proc))
01482     send_buf = send
01483     call mpi_allgather(send_buf, n_data, MPI_DOUBLE_PRECISION, &
01484          recv_buf, n_data, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr)
01485     call pmc_mpi_check_ierr(ierr)
01486     recv = reshape(recv_buf, (/n_data, n_proc/))
01487     deallocate(send_buf)
01488     deallocate(recv_buf)
01489 #else
01490     recv(:, 1) = send
01491 #endif
01492 
01493   end subroutine pmc_mpi_allgather_real_array
01494 
01495 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
01496 
01497 end module pmc_mpi