!!****************************************************************************** !! !! This file is part of the AMUN source code, a program to perform !! Newtonian or relativistic magnetohydrodynamical simulations on uniform or !! adaptive mesh. !! !! Copyright (C) 2008-2020 Grzegorz Kowal !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License as published by !! the Free Software Foundation, either version 3 of the License, or !! (at your option) any later version. !! !! This program is distributed in the hope that it will be useful, !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see . !! !!****************************************************************************** !! !! module: MPITOOLS !! !! This module provides wrapper subroutines handling the parallel execution !! with the Message Passing Interface protocol. !! !! !!****************************************************************************** ! module mpitools ! include external subroutines ! use timers, only : set_timer, start_timer, stop_timer ! module variables are not implicit by default ! implicit none ! timer indices ! integer , save :: imi, imc #ifdef PROFILE integer , save :: imb, imm, ims, imr, ime #endif /* PROFILE */ ! MPI global variables ! integer(kind=4), save :: comm integer(kind=4), save :: nproc, nprocs, npmax, npairs logical , save :: master = .true. ! allocatable array for processor pairs ! integer(kind=4), dimension(:,:), allocatable, save :: pairs ! by default everything is public ! public !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! contains ! !=============================================================================== !! !!*** PUBLIC SUBROUTINES ***************************************************** !! !=============================================================================== ! ! subroutine INITIALIZE_MPITOOLS: ! ------------------------------ ! ! Subroutine initializes the MPITOOLS modules. ! ! Arguments: ! ! status - the return value; if it is 0 everything went successfully, ! otherwise there was a problem; ! !=============================================================================== ! subroutine initialize_mpitools(status) ! include external procedures and variables ! use iso_fortran_env, only : error_unit #ifdef MPI use mpi , only : mpi_comm_world, mpi_success #endif /* MPI */ ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer, intent(out) :: status ! local variables ! #ifdef MPI integer :: mprocs, i, j, l, n ! allocatable array for processors order ! integer(kind=4), dimension(:), allocatable :: procs #endif /* MPI */ ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::initialize_mpitools()' ! !------------------------------------------------------------------------------- ! #ifdef MPI ! set timer descriptions ! call set_timer('MPI initialization' , imi) call set_timer('MPI communication' , imc) #ifdef PROFILE call set_timer('mpitools:: broadcast', imb) call set_timer('mpitools:: reduce' , imm) call set_timer('mpitools:: send' , ims) call set_timer('mpitools:: receive' , imr) call set_timer('mpitools:: exchange' , ime) #endif /* PROFILE */ ! start time accounting for the MPI initialization ! call start_timer(imi) #endif /* MPI */ ! reset the status flag ! status = 0 ! initialize parralel execution parameters and return flag ! nproc = 0 nprocs = 1 npmax = 0 npairs = 0 #ifdef MPI ! initialize the MPI interface ! call mpi_init(status) ! check if the MPI interface was initialized successfully ! if (status == mpi_success) then ! obtain the total number of processes ! call mpi_comm_size(mpi_comm_world, nprocs, status) ! check if the total number of processes could be obtained ! if (status == mpi_success) then ! obtain the current process identifier ! call mpi_comm_rank(mpi_comm_world, nproc , status) ! check if the process ID was return successfully ! if (status == mpi_success) then ! store the MPI communicator ! comm = mpi_comm_world ! set the master flag ! master = nproc == 0 ! calculate the index of the last processor ! npmax = nprocs - 1 ! round up the number of processors to even number ! mprocs = nprocs + mod(nprocs, 2) ! calculate the number of processor pairs for data exchange ! npairs = nprocs * npmax / 2 ! allocate space for the processor order and all processor pairs ! allocate(procs(mprocs), pairs(2 * npairs, 2), stat = status) if (status == 0) then ! fill the processor order array ! procs(:) = (/(l, l = 0, mprocs - 1)/) ! generate processor pairs ! n = 0 ! iterate over turns ! do l = 1, mprocs - 1 ! generate pairs for a given turn ! do i = 1, mprocs / 2 ! calculate the pair for the current processor ! j = mprocs - i + 1 ! continue, if the process number is correct (for odd nprocs case) ! if (procs(i) < nprocs .and. procs(j) < nprocs) then ! increase the pair number ! n = n + 1 ! substitute the processor numbers for the current pair ! pairs(n,1:2) = (/ procs(i), procs(j) /) end if ! max(procs(i), procs(j)) < nprocs end do ! i = 1, mprocs / 2 ! shift elements in the processor order array ! procs(2:mprocs) = cshift(procs(2:mprocs), -1) end do ! l = 1, mprocs - 1 ! fill out the remaining pairs (swapped) ! pairs(npairs+1:2*npairs,1:2) = pairs(1:npairs,2:1:-1) ! allocate space for the processor order ! deallocate(procs, stat = status) end if ! allocate else write(error_unit,"('[', a, ']: ', a)") trim(loc) & , "The MPI process ID could not be obtained!" status = 1 end if else write(error_unit,"('[', a, ']: ', a)") trim(loc) & , "The MPI process ID could not be obtained!" status = 1 end if else write(error_unit,"('[', a, ']: ', a)") trim(loc) & , "The MPI interface could not be initializes!" status = 1 end if ! stop time accounting for the MPI initialization ! call stop_timer(imi) #endif /* MPI */ !------------------------------------------------------------------------------- ! end subroutine initialize_mpitools ! !=============================================================================== ! ! subroutine FINALIZE_MPITOOLS: ! ---------------------------- ! ! Subroutine finalizes the MPITOOLS modules. ! ! Arguments: ! ! status - the return value; if it is 0 everything went successfully, ! otherwise there was a problem; ! !=============================================================================== ! subroutine finalize_mpitools(status) ! include external procedures and variables ! use iso_fortran_env, only : error_unit #ifdef MPI use mpi , only : mpi_comm_world, mpi_success #endif /* MPI */ ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer, intent(out) :: status ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::finalize_mpitools()' ! !------------------------------------------------------------------------------- ! ! reset the status flag ! status = 0 #ifdef MPI ! start time accounting for the MPI initialization ! call start_timer(imi) ! deallocate space used for processor pairs ! if (allocated(pairs)) deallocate(pairs, stat = status) ! initialize the MPI interface ! call mpi_finalize(status) ! check if the MPI interface was finalizes successfully ! if (status /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "MPI finalization failed!" end if ! stop time accounting for the MPI initialization ! call stop_timer(imi) #endif /* MPI */ !------------------------------------------------------------------------------- ! end subroutine finalize_mpitools ! !=============================================================================== ! ! subroutine CHECK_STATUS: ! ----------------------- ! ! Subroutine calculates the logical OR for input values from all MPI ! processes, if MPI is used, otherwise, just returns the input value. ! ! Arguments: ! ! ibuf - the logical buffer; ! !=============================================================================== ! logical function check_status(ibuf) result(obuf) #ifdef MPI ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_comm_world, mpi_logical, mpi_lor, mpi_success #endif /* MPI */ ! local variables are not implicit by default ! implicit none ! subroutine arguments ! logical, intent(in) :: ibuf #ifdef MPI ! local variables ! integer :: iret ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::check_status()' #endif /* MPI */ ! !------------------------------------------------------------------------------- ! #ifdef MPI ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(ibuf, obuf, 1, & mpi_logical, mpi_lor, mpi_comm_world, iret) ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! stop time accounting for the MPI communication ! call stop_timer(imc) #else /* MPI */ ! no MPI, so just copy the input to output ! obuf = ibuf #endif /* MPI */ !------------------------------------------------------------------------------- ! end function check_status #ifdef MPI ! !=============================================================================== ! ! subroutine BCAST_INTEGER_VARIABLE: ! --------------------------------- ! ! Subroutine broadcast an integer variable from the master process to all ! other processes. ! !=============================================================================== ! subroutine bcast_integer_variable(ibuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_integer, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer, intent(inout) :: ibuf integer, intent(inout) :: iret ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::bcast_integer_variable()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI broadcast ! call start_timer(imb) #endif /* PROFILE */ call mpi_bcast(ibuf, 1, mpi_integer, 0, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI broadcast ! call stop_timer(imb) #endif /* PROFILE */ if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine bcast_integer_variable ! !=============================================================================== ! ! subroutine BCAST_REAL_VARIABLE: ! ------------------------------ ! ! Subroutine broadcast a real variable from the master process to all ! other processes. ! !=============================================================================== ! subroutine bcast_real_variable(rbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! real(kind=8), intent(inout) :: rbuf integer , intent(inout) :: iret ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::bcast_real_variable()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI broadcast ! call start_timer(imb) #endif /* PROFILE */ call mpi_bcast(rbuf, 1, mpi_real8, 0, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI broadcast ! call stop_timer(imb) #endif /* PROFILE */ if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine bcast_real_variable ! !=============================================================================== ! ! subroutine BCAST_STRING_VARIABLE: ! -------------------------------- ! ! Subroutine broadcast a string variable from the master process to all ! other processes. ! !=============================================================================== ! subroutine bcast_string_variable(sbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_character, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! character(len=*), intent(inout) :: sbuf integer , intent(out) :: iret ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::bcast_string_variable()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI broadcast ! call start_timer(imb) #endif /* PROFILE */ call mpi_bcast(sbuf, len(sbuf), mpi_character, 0, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI broadcast ! call stop_timer(imb) #endif /* PROFILE */ if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine bcast_string_variable ! !=============================================================================== ! ! subroutine REDUCE_MINIMUM_INTEGER: ! --------------------------------- ! ! Subroutine finds the minimum value among the integer values from all ! processes. ! !=============================================================================== ! subroutine reduce_minimum_integer(ibuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_integer, mpi_min, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer, intent(inout) :: ibuf integer, intent(out) :: iret ! local variables ! integer :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_minimum_integer()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(ibuf, tbuf, 1, mpi_integer, mpi_min, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! ibuf = tbuf ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_minimum_integer ! !=============================================================================== ! ! subroutine REDUCE_MINIMUM_REAL: ! ------------------------------ ! ! Subroutine finds the minimum value among the real values from all processes. ! !=============================================================================== ! subroutine reduce_minimum_real(rbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_min, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! real(kind=8), intent(inout) :: rbuf integer , intent(out) :: iret ! local variables ! real(kind=8) :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_minimum_real()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(rbuf, tbuf, 1, mpi_real8, mpi_min, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! rbuf = tbuf ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_minimum_real ! !=============================================================================== ! ! subroutine REDUCE_MAXIMUM_INTEGER: ! --------------------------------- ! ! Subroutine find the maximum value among the integer values from all ! processes. ! !=============================================================================== ! subroutine reduce_maximum_integer(ibuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_integer, mpi_max, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer, intent(inout) :: ibuf integer, intent(out) :: iret ! local variables ! integer :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_maximum_integer()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(ibuf, tbuf, 1, mpi_integer, mpi_max, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! ibuf = tbuf ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_maximum_integer ! !=============================================================================== ! ! subroutine REDUCE_MAXIMUM_REAL: ! ------------------------------ ! ! Subroutine find the maximum value among the values from all processes. ! !=============================================================================== ! subroutine reduce_maximum_real(rbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_max, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! real(kind=8), intent(inout) :: rbuf integer , intent(out) :: iret ! local variables ! real(kind=8) :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_maximum_real()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(rbuf, tbuf, 1, mpi_real8, mpi_max, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! rbuf = tbuf ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_maximum_real ! !=============================================================================== ! ! subroutine REDUCE_SUM_INTEGER: ! ----------------------------- ! ! Subroutine finds the sum from all integer values from all processes. ! !=============================================================================== ! subroutine reduce_sum_integer(ibuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_integer, mpi_sum, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer, intent(inout) :: ibuf integer, intent(out) :: iret ! local variables ! integer :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_integer()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(ibuf, tbuf, 1, mpi_integer, mpi_sum, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! ibuf = tbuf ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_sum_integer ! !=============================================================================== ! ! subroutine REDUCE_SUM_REAL: ! -------------------------- ! ! Subroutine sums the values from all processes. ! !=============================================================================== ! subroutine reduce_sum_real(rbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_sum, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! real(kind=8), intent(inout) :: rbuf integer , intent(out) :: iret ! local variables ! real(kind=8) :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_real()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(rbuf, tbuf, 1, mpi_real8, mpi_sum, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! rbuf = tbuf ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_sum_real ! !=============================================================================== ! ! subroutine REDUCE_MINIMUM_REAL_ARRAY: ! ------------------------------------ ! ! Subroutine find the minimum value for each array element among the ! corresponding values from all processes. ! !=============================================================================== ! subroutine reduce_minimum_real_array(n, rbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_min, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer , intent(in) :: n real(kind=8), dimension(n), intent(inout) :: rbuf integer , intent(out) :: iret ! local variables ! real(kind=8), dimension(n) :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_minimum_real_array()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(rbuf, tbuf, n, mpi_real8, mpi_min, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! rbuf(:) = tbuf(:) ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_minimum_real_array ! !=============================================================================== ! ! subroutine REDUCE_MAXIMUM_REAL_ARRAY: ! ------------------------------------ ! ! Subroutine find the maximum value for each array element among the ! corresponding values from all processes. ! !=============================================================================== ! subroutine reduce_maximum_real_array(n, rbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_max, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer , intent(in) :: n real(kind=8), dimension(n), intent(inout) :: rbuf integer , intent(out) :: iret ! local variables ! real(kind=8), dimension(n) :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_maximum_real_array()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(rbuf, tbuf, n, mpi_real8, mpi_max, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! rbuf(:) = tbuf(:) ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_maximum_real_array ! !=============================================================================== ! ! subroutine REDUCE_SUM_INTEGER_ARRAY: ! ----------------------------------- ! ! Subroutine sums the values for each array element from the corresponding ! values from all processes. ! !=============================================================================== ! subroutine reduce_sum_integer_array(n, ibuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_integer, mpi_sum, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer , intent(in) :: n integer, dimension(n), intent(inout) :: ibuf integer , intent(out) :: iret ! local variables ! integer, dimension(n) :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_integer_array()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(ibuf, tbuf, n, mpi_integer, mpi_sum, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! ibuf(:) = tbuf(:) ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_sum_integer_array ! !=============================================================================== ! ! subroutine REDUCE_SUM_REAL_ARRAY: ! -------------------------------- ! ! Subroutine sums the values for each array element from the corresponding ! values from all processes. ! !=============================================================================== ! subroutine reduce_sum_real_array(n, rbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_sum, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer , intent(in) :: n real(kind=8), dimension(n), intent(inout) :: rbuf integer , intent(out) :: iret ! local variables ! real(kind=8), dimension(n) :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_real_array()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(rbuf, tbuf, n, mpi_real8, mpi_sum, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! rbuf(:) = tbuf(:) ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_sum_real_array ! !=============================================================================== ! ! subroutine REDUCE_SUM_COMPLEX_ARRAY: ! ----------------------------------- ! ! Subroutine sums the values for each array element from the corresponding ! complex values from all processes. ! !=============================================================================== ! subroutine reduce_sum_complex_array(n, cbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_double_complex, mpi_sum, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer , intent(in) :: n complex(kind=8), dimension(n), intent(inout) :: cbuf integer , intent(out) :: iret ! local variables ! complex(kind=8), dimension(n) :: tbuf ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_complex_array()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI reduce ! call start_timer(imm) #endif /* PROFILE */ call mpi_allreduce(cbuf, tbuf, n, mpi_double_complex, mpi_sum, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI reduce ! call stop_timer(imm) #endif /* PROFILE */ ! substitute the result ! cbuf(:) = tbuf(:) ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine reduce_sum_complex_array ! !=============================================================================== ! ! subroutine SEND_REAL_ARRAY: ! -------------------------- ! ! Subroutine sends an arrays of real values to another process. ! ! Arguments: ! ! n - the number of array elements; ! dst - the ID of the destination process; ! tag - the tag identifying this operation; ! rbuf - the real array to send; ! iret - the result flag identifying if the operation was successful; ! !=============================================================================== ! subroutine send_real_array(n, dst, tag, rbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_success ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer , intent(in) :: n, dst, tag real(kind=8), dimension(n), intent(in) :: rbuf integer , intent(out) :: iret ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::send_real_array()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI send ! call start_timer(ims) #endif /* PROFILE */ call mpi_send(rbuf, n, mpi_real8, dst, tag, comm, iret) #ifdef PROFILE ! stop time accounting for the MPI send ! call stop_timer(ims) #endif /* PROFILE */ ! check if the operation was successful ! if (iret /= mpi_success .and. master) then write(error_unit,"('[', a, ']: ', 2(a, i9))") trim(loc) & , "Could not send real array from ", nproc, " to ", dst end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine send_real_array ! !=============================================================================== ! ! subroutine RECEIVE_REAL_ARRAY: ! ----------------------------- ! ! Subroutine receives an arrays of real values from another process. ! ! Arguments: ! ! n - the number of array elements; ! src - the7 ID of the source process; ! tag - the tag identifying this operation; ! rbuf - the received real array; ! iret - the result flag identifying if the operation was successful; ! !=============================================================================== ! subroutine receive_real_array(n, src, tag, rbuf, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_success, mpi_status_size ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer , intent(in) :: n, src, tag real(kind=8), dimension(n), intent(out) :: rbuf integer , intent(out) :: iret ! local variables ! integer :: status(mpi_status_size) ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::receive_real_array()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI receive ! call start_timer(imr) #endif /* PROFILE */ call mpi_recv(rbuf, n, mpi_real8, src, tag, comm, status, iret) #ifdef PROFILE ! stop time accounting for the MPI receive ! call stop_timer(imr) #endif /* PROFILE */ ! check if the operation was successful ! if (iret /= mpi_success) then write(error_unit,"('[', a, ']: ', 2(a, i9))") trim(loc) & , "Could not receive real array from ", src, " to ", nproc end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine receive_real_array ! !=============================================================================== ! ! subroutine EXCHANGE_REAL_ARRAYS: ! ------------------------------- ! ! Subroutine exchanges real data buffers between two processes. ! ! Arguments: ! ! proc - the remote process number to which send the buffer sbuf, ! and from which receive the buffer rbuf; ! tag - the tag identifying the send operation; ! ssize - the size of the send buffer sbuf; ! sbuf - the real array buffer to send; ! rsize - the size of the receive buffer rbuf; ! rbuf - the real array buffer to receive; ! iret - the result flag identifying if the operation was successful; ! !=============================================================================== ! subroutine exchange_real_arrays(proc, tag, ssize, sbuffer & , rsize, rbuffer, iret) ! include external procedures and variables ! use iso_fortran_env, only : error_unit use mpi , only : mpi_real8, mpi_success, mpi_status_size ! local variables are not implicit by default ! implicit none ! subroutine arguments ! integer , intent(in) :: proc, tag integer , intent(in) :: ssize, rsize real(kind=8), dimension(ssize), intent(in) :: sbuffer real(kind=8), dimension(rsize), intent(in) :: rbuffer integer , intent(out) :: iret ! local variables ! integer :: status(mpi_status_size) ! local parameters ! character(len=*), parameter :: loc = 'MPITOOLS::exchange_real_arrays()' ! !------------------------------------------------------------------------------- ! ! start time accounting for the MPI communication ! call start_timer(imc) #ifdef PROFILE ! start time accounting for the MPI buffer exchange ! call start_timer(ime) #endif /* PROFILE */ ! send sbuf and receive rbuf ! call mpi_sendrecv(sbuffer(:), ssize, mpi_real8, proc, tag & , rbuffer(:), rsize, mpi_real8, proc, tag & , comm, status, iret) #ifdef PROFILE ! stop time accounting for the MPI buffer exchange ! call stop_timer(ime) #endif /* PROFILE */ ! check if the operation was successful ! if (iret /= mpi_success) then write(error_unit,"('[', a, ']: ', 2(a, i9),'.')") trim(loc) & , "Could not exchange real data buffers between " & , proc, "and", nproc end if ! stop time accounting for the MPI communication ! call stop_timer(imc) !------------------------------------------------------------------------------- ! end subroutine exchange_real_arrays ! !=============================================================================== !! !!*** PRIVATE SUBROUTINES **************************************************** !! !=============================================================================== ! #endif /* MPI */ !=============================================================================== ! end module mpitools