PartMC 2.1.4
|
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 end module pmc_mpi