From 6833a0d7414bc28421905b7de9ff589a6afd5d43 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Fri, 14 Aug 2020 13:27:08 +0000 Subject: [PATCH 1/5] Update .gitlab-ci.yml --- .gitlab-ci.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f6ef11d..a123a95 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,8 +1,7 @@ image: debian stages: - - build amun 1/2 - - build amun 2/2 + - build build amun 1/2: stage: build From 9b7fe356505ddd275a45ca64395da0fa9544941f Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Fri, 14 Aug 2020 13:39:58 +0000 Subject: [PATCH 2/5] Update .gitlab-ci.yml to use .pre stage. --- .gitlab-ci.yml | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index a123a95..f0024ff 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -3,12 +3,14 @@ image: debian stages: - build +prepare packages: + stage: .pre + script: + - apt -q update + - apt -q -y install gawk cmake gfortran libhdf5-dev libopenmpi-dev libzstd-dev liblz4-dev liblzma-dev pkg-config + build amun 1/2: stage: build - before_script: - - apt -q update - - apt -q -y install gawk make gfortran libhdf5-dev libopenmpi-dev - script: - cd ./build/ - cp -al make.default make.config @@ -24,10 +26,6 @@ build amun 1/2: build amun 2/2: stage: build - before_script: - - apt -q update - - apt -q -y install cmake gfortran libhdf5-dev libopenmpi-dev libzstd-dev liblz4-dev liblzma-dev pkg-config - script: - mkdir ./build-cmake/ - cd ./build-cmake/ From 8108a445a361a3dfdf5ad43b1de6d3f01889637a Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Fri, 14 Aug 2020 13:42:18 +0000 Subject: [PATCH 3/5] Revert "Update .gitlab-ci.yml to use .pre stage." This reverts commit 9b7fe356505ddd275a45ca64395da0fa9544941f --- .gitlab-ci.yml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f0024ff..a123a95 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -3,14 +3,12 @@ image: debian stages: - build -prepare packages: - stage: .pre - script: - - apt -q update - - apt -q -y install gawk cmake gfortran libhdf5-dev libopenmpi-dev libzstd-dev liblz4-dev liblzma-dev pkg-config - build amun 1/2: stage: build + before_script: + - apt -q update + - apt -q -y install gawk make gfortran libhdf5-dev libopenmpi-dev + script: - cd ./build/ - cp -al make.default make.config @@ -26,6 +24,10 @@ build amun 1/2: build amun 2/2: stage: build + before_script: + - apt -q update + - apt -q -y install cmake gfortran libhdf5-dev libopenmpi-dev libzstd-dev liblz4-dev liblzma-dev pkg-config + script: - mkdir ./build-cmake/ - cd ./build-cmake/ From c15378bdddab0e9f937c6aed16310cc4f7d70ac7 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Fri, 14 Aug 2020 19:40:10 -0300 Subject: [PATCH 4/5] MPITOOLS: Rewrite MPI support using Fortran 2008 interface. Use procedure interfaces, remove unused variables, etc. Signed-off-by: Grzegorz Kowal --- sources/boundaries.F90 | 70 +-- sources/driver.F90 | 4 +- sources/evolution.F90 | 8 +- sources/forcing.F90 | 8 +- sources/integrals.F90 | 15 +- sources/mesh.F90 | 21 +- sources/mpitools.F90 | 1276 +++++++++------------------------------- 7 files changed, 330 insertions(+), 1072 deletions(-) diff --git a/sources/boundaries.F90 b/sources/boundaries.F90 index ed9011a..080048d 100644 --- a/sources/boundaries.F90 +++ b/sources/boundaries.F90 @@ -565,7 +565,7 @@ module boundaries use equations , only : nf #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -595,7 +595,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -962,8 +962,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! @@ -1363,7 +1362,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -1392,7 +1391,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -1617,8 +1616,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! @@ -1726,7 +1724,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -1753,7 +1751,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -1966,8 +1964,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! @@ -2078,7 +2075,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -2107,7 +2104,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -2359,8 +2356,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! @@ -2502,7 +2498,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -2532,7 +2528,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -2818,8 +2814,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! @@ -2949,7 +2944,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -2979,7 +2974,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -3243,8 +3238,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! @@ -3379,7 +3373,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -3409,7 +3403,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -3722,8 +3716,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! @@ -3888,7 +3881,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -3914,7 +3907,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -4167,8 +4160,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! @@ -4281,7 +4273,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -4307,7 +4299,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -4537,8 +4529,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! @@ -4651,7 +4642,7 @@ module boundaries use equations , only : nv #ifdef MPI use mpitools , only : nproc, npairs, pairs - use mpitools , only : exchange_real_arrays + use mpitools , only : exchange_arrays #endif /* MPI */ ! local variables are not implicit by default @@ -4677,7 +4668,7 @@ module boundaries #ifdef MPI integer :: sproc = 0, rproc = 0 integer :: scount, rcount - integer :: l, p, iret + integer :: l, p ! local arrays ! @@ -4907,8 +4898,7 @@ module boundaries !! ! exchange data ! - call exchange_real_arrays(rproc, p, size(sbuf), sbuf & - , size(rbuf), rbuf, iret) + call exchange_arrays(rproc, p, sbuf, rbuf) !! PROCESS RECEIVED BLOCKS !! diff --git a/sources/driver.F90 b/sources/driver.F90 index 83c286c..7156863 100644 --- a/sources/driver.F90 +++ b/sources/driver.F90 @@ -67,7 +67,7 @@ program amun use mesh , only : generate_mesh, store_mesh_stats use mpitools , only : initialize_mpitools, finalize_mpitools #ifdef MPI - use mpitools , only : bcast_integer_variable, reduce_sum_real_array + use mpitools , only : reduce_sum #endif /* MPI */ use mpitools , only : master, nprocs, nproc, check_status use operators , only : initialize_operators, finalize_operators @@ -898,7 +898,7 @@ program amun #ifdef MPI ! sum up timers from all processes ! - call reduce_sum_real_array(ntimers, tm(:), status) + call reduce_sum(tm(1:ntimers)) #endif /* MPI */ ! print timings only on master processor diff --git a/sources/evolution.F90 b/sources/evolution.F90 index ea8d3f3..4e66c8e 100644 --- a/sources/evolution.F90 +++ b/sources/evolution.F90 @@ -509,7 +509,7 @@ module evolution ! use equations , only : maxspeed, cmax, cmax2 #ifdef MPI - use mpitools , only : reduce_maximum_real, reduce_maximum_integer + use mpitools , only : reduce_maximum #endif /* MPI */ ! include external variables @@ -535,7 +535,7 @@ module evolution ! local variables ! - integer :: iret, mlev + integer :: mlev real(kind=8) :: cm, dx_min ! local parameters @@ -585,8 +585,8 @@ module evolution #ifdef MPI ! reduce maximum speed and level over all processors ! - call reduce_maximum_real (cmax, iret) - call reduce_maximum_integer(mlev, iret) + call reduce_maximum(cmax) + call reduce_maximum(mlev) #endif /* MPI */ ! calculate the squared cmax diff --git a/sources/forcing.F90 b/sources/forcing.F90 index 7838d40..c9d04fc 100644 --- a/sources/forcing.F90 +++ b/sources/forcing.F90 @@ -1654,17 +1654,13 @@ module forcing ! use blocks , only : block_data, list_data #ifdef MPI - use mpitools, only : reduce_sum_complex_array + use mpitools, only : reduce_sum #endif /* MPI */ ! local variables are not implicit by default ! implicit none -! local variables -! - integer :: status - ! local pointers ! type(block_data), pointer :: pdata @@ -1696,7 +1692,7 @@ module forcing #ifdef MPI ! reduce velocity coefficients over all processes ! - call reduce_sum_complex_array(size(vcoefs), vcoefs, status) + call reduce_sum(vcoefs) #endif /* MPI */ !------------------------------------------------------------------------------- diff --git a/sources/integrals.F90 b/sources/integrals.F90 index 834ba2b..1f805df 100644 --- a/sources/integrals.F90 +++ b/sources/integrals.F90 @@ -327,9 +327,7 @@ module integrals use evolution , only : step, time, dtn use forcing , only : einj, rinj, arms #ifdef MPI - use mpitools , only : reduce_sum_real_array - use mpitools , only : reduce_minimum_real_array - use mpitools , only : reduce_maximum_real_array + use mpitools , only : reduce_minimum, reduce_maximum, reduce_sum #endif /* MPI */ ! local variables are not implicit by default @@ -338,8 +336,7 @@ module integrals ! local variables ! - integer :: iret - real(kind=8) :: dvol, dvolh + real(kind=8) :: dvol, dvolh ! local pointers ! @@ -567,13 +564,13 @@ module integrals #ifdef MPI ! sum the integral array from all processes ! - call reduce_sum_real_array(narr, inarr(:), iret) + call reduce_sum(inarr(1:narr)) ! reduce average, minimum and maximum values ! - call reduce_sum_real_array(narr, avarr(:), iret) - call reduce_minimum_real_array(narr, mnarr(:), iret) - call reduce_maximum_real_array(narr, mxarr(:), iret) + call reduce_sum(avarr(1:narr)) + call reduce_minimum(mnarr(1:narr)) + call reduce_maximum(mxarr(1:narr)) #endif /* MPI */ ! calculate the internal energy diff --git a/sources/mesh.F90 b/sources/mesh.F90 index 155079d..12fd75f 100644 --- a/sources/mesh.F90 +++ b/sources/mesh.F90 @@ -903,7 +903,7 @@ module mesh use coordinates , only : nn => bcells use equations , only : nv use mpitools , only : nprocs, npmax, nproc - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : send_array, receive_array #endif /* MPI */ ! local variables are not implicit by default @@ -914,7 +914,6 @@ module mesh ! local variables ! integer :: status - integer :: iret integer(kind=4) :: np, nl ! local pointers @@ -995,7 +994,7 @@ module mesh ! send data ! - call send_real_array(size(rbuf), np, itag, rbuf, iret) + call send_array(np, itag, rbuf) ! remove data block from the current process ! @@ -1016,7 +1015,7 @@ module mesh ! receive the data ! - call receive_real_array(size(rbuf), pmeta%process, itag, rbuf, iret) + call receive_array(pmeta%process, itag, rbuf) ! coppy the buffer to data block ! @@ -1535,7 +1534,7 @@ module mesh #ifdef DEBUG use mpitools , only : nproc #endif /* DEBUG */ - use mpitools , only : reduce_sum_integer_array + use mpitools , only : reduce_sum #endif /* MPI */ use refinement , only : check_refinement_criterion @@ -1556,7 +1555,6 @@ module mesh ! local variables ! integer(kind=4) :: nl, l - integer :: iret ! array for storing the refinement flags ! @@ -1677,7 +1675,7 @@ module mesh ! update refinement flags across all processes ! - call reduce_sum_integer_array(nl, ibuf(1:nl), iret) + call reduce_sum(ibuf(1:nl)) ! reset the leaf block counter ! @@ -1844,7 +1842,7 @@ module mesh use iso_fortran_env, only : error_unit #ifdef MPI use mpitools , only : nprocs, nproc - use mpitools , only : send_real_array, receive_real_array + use mpitools , only : send_array, receive_array #endif /* MPI */ ! local variables are not implicit by default @@ -1871,7 +1869,6 @@ module mesh ! tag for the MPI data exchange ! integer(kind=4) :: itag - integer :: iret ! local buffer for data block exchange ! @@ -2070,8 +2067,7 @@ module mesh ! send data ! - call send_real_array(size(rbuf), pmeta%process & - , itag, rbuf(:,:,:,:), iret) + call send_array(pmeta%process, itag, rbuf) ! deallocate the associated data block (it has to be pchild%data, and not pdata, ! otherwise, pchild%data won't be nullified) @@ -2093,8 +2089,7 @@ module mesh ! receive the data ! - call receive_real_array(size(rbuf) & - , pchild%process, itag, rbuf(:,:,:,:), iret) + call receive_array(pchild%process, itag, rbuf(:,:,:,:)) ! allocate data block for the current child ! diff --git a/sources/mpitools.F90 b/sources/mpitools.F90 index ac65d6b..8e41d20 100644 --- a/sources/mpitools.F90 +++ b/sources/mpitools.F90 @@ -33,32 +33,62 @@ module mpitools ! include external subroutines ! +#ifdef MPI + use mpi_f08 +#endif /* MPI */ use timers, only : set_timer, start_timer, stop_timer ! module variables are not implicit by default ! implicit none +! subroutine interfaces +! + interface reduce_minimum + module procedure reduce_minimum_double_array + end interface + interface reduce_maximum + module procedure reduce_maximum_integer + module procedure reduce_maximum_double + module procedure reduce_maximum_double_array + end interface + interface reduce_sum + module procedure reduce_sum_integer_array + module procedure reduce_sum_double_array + module procedure reduce_sum_complex_array + end interface + ! timer indices ! - integer , save :: imi, imc + integer, save :: imi, imc #ifdef PROFILE - integer , save :: imb, imm, ims, imr, ime + 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. + 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 +! by default everything is private ! - public + private + +! declare public subroutines +! + public :: initialize_mpitools, finalize_mpitools + public :: check_status + public :: reduce_minimum, reduce_maximum, reduce_sum + public :: send_array, receive_array + public :: exchange_arrays + +! declare public variables +! + public :: master, nproc, nprocs, npmax, npairs, pairs !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! @@ -87,9 +117,6 @@ module mpitools ! 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 ! @@ -99,10 +126,11 @@ module mpitools ! integer, intent(out) :: status +#ifdef MPI ! local variables ! -#ifdef MPI integer :: mprocs, i, j, l, n + integer :: ierror ! allocatable array for processors order ! @@ -116,8 +144,6 @@ module mpitools !------------------------------------------------------------------------------- ! #ifdef MPI -! set timer descriptions -! call set_timer('MPI initialization' , imi) call set_timer('MPI communication' , imc) #ifdef PROFILE @@ -128,143 +154,90 @@ module mpitools 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 +! initialize the MPI parallelization ! - call mpi_init(status) + call MPI_Init(ierror) -! check if the MPI interface was initialized successfully -! - if (status == mpi_success) then + if (ierror == MPI_SUCCESS) then -! obtain the total number of processes -! - call mpi_comm_size(mpi_comm_world, nprocs, status) + call MPI_Comm_size(MPI_COMM_WORLD, nprocs, ierror) -! check if the total number of processes could be obtained -! - if (status == mpi_success) then + if (ierror == MPI_SUCCESS) then -! obtain the current process identifier -! - call mpi_comm_rank(mpi_comm_world, nproc , status) + call MPI_Comm_rank(MPI_COMM_WORLD, nproc, ierror) -! check if the process ID was return successfully -! - if (status == mpi_success) then - -! store the MPI communicator -! - comm = mpi_comm_world + if (ierror == MPI_SUCCESS) then ! set the master flag ! master = nproc == 0 -! calculate the index of the last processor +! allocate and fill up the array of processes and process pairs ! 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!" + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "Could not get the MPI process ID!" status = 1 end if else - write(error_unit,"('[', a, ']: ', a)") trim(loc) & - , "The MPI process ID could not be obtained!" + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "Could not get the number of MPI processes!" status = 1 end if else - write(error_unit,"('[', a, ']: ', a)") trim(loc) & - , "The MPI interface could not be initializes!" + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "Could not initialize the MPI interface!" status = 1 end if -! stop time accounting for the MPI initialization -! call stop_timer(imi) #endif /* MPI */ @@ -291,9 +264,6 @@ module mpitools ! include external procedures and variables ! use iso_fortran_env, only : error_unit -#ifdef MPI - use mpi , only : mpi_success -#endif /* MPI */ ! local variables are not implicit by default ! @@ -303,19 +273,21 @@ module mpitools ! integer, intent(out) :: status +#ifdef MPI +! local variables +! + integer :: ierror +#endif /* MPI */ + ! 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 @@ -324,16 +296,14 @@ module mpitools ! initialize the MPI interface ! - call mpi_finalize(status) + call MPI_Finalize(ierror) -! 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!" + if (ierror /= MPI_SUCCESS) then + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "Could not finalize the MPI interface!" + status = 1 end if -! stop time accounting for the MPI initialization -! call stop_timer(imi) #endif /* MPI */ @@ -357,12 +327,9 @@ module mpitools ! 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 ! @@ -375,7 +342,7 @@ module mpitools #ifdef MPI ! local variables ! - integer :: iret + integer :: ierror ! local parameters ! @@ -385,33 +352,23 @@ module mpitools !------------------------------------------------------------------------------- ! #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) + call MPI_Allreduce(ibuf, obuf, 1, & + MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ierror) -! check if the operation was successful -! - if (iret /= mpi_success .and. master) then - write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" + if (ierror /= MPI_SUCCESS) then + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "MPI_Allreduce of logical buffer 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 @@ -422,336 +379,231 @@ module mpitools !------------------------------------------------------------------------------- ! end function check_status +! #ifdef MPI ! !=============================================================================== ! -! subroutine BCAST_INTEGER_VARIABLE: -! --------------------------------- +! subroutine SEND_ARRAY: +! --------------------- ! -! Subroutine broadcast an integer variable from the master process to all -! other processes. +! Subroutine sends an arrays of real values to another process. +! +! Arguments: +! +! dst - the ID of the destination process; +! tag - the tag identifying this operation; +! buf - the buffer of real values to send; ! !=============================================================================== ! - subroutine bcast_integer_variable(ibuf, iret) + subroutine send_array(dst, tag, buf) -! 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 + integer , intent(in) :: dst, tag + real(kind=8), dimension(..), intent(in) :: buf -! local parameters -! - character(len=*), parameter :: loc = 'MPITOOLS::bcast_integer_variable()' + integer :: ierror + + character(len=*), parameter :: loc = 'MPITOOLS::send_array()' ! !------------------------------------------------------------------------------- -! -! start time accounting for the MPI communication ! call start_timer(imc) - #ifdef PROFILE -! start time accounting for the MPI broadcast -! - call start_timer(imb) + call start_timer(ims) #endif /* PROFILE */ - call mpi_bcast(ibuf, 1, mpi_integer, 0, comm, iret) + call MPI_Send(buf, size(buf), MPI_REAL8, dst, tag, MPI_COMM_WORLD, ierror) #ifdef PROFILE -! stop time accounting for the MPI broadcast -! - call stop_timer(imb) + call stop_timer(ims) #endif /* PROFILE */ - if (iret /= mpi_success .and. master) then - write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" + if (ierror /= MPI_SUCCESS) 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 bcast_integer_variable + end subroutine send_array ! !=============================================================================== ! -! subroutine BCAST_REAL_VARIABLE: -! ------------------------------ +! subroutine RECEIVE_ARRAY: +! ------------------------ ! -! Subroutine broadcast a real variable from the master process to all -! other processes. +! Subroutine receives an arrays of real values from another process. +! +! Arguments: +! +! src - the ID of the source process; +! tag - the tag identifying this operation; +! buf - the received real array; ! !=============================================================================== ! - subroutine bcast_real_variable(rbuf, iret) + subroutine receive_array(src, tag, buf) -! 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 + integer , intent(in) :: src, tag + real(kind=8), dimension(..), intent(out) :: buf -! local parameters -! - character(len=*), parameter :: loc = 'MPITOOLS::bcast_real_variable()' + integer :: ierror + + character(len=*), parameter :: loc = 'MPITOOLS::receive_array()' ! !------------------------------------------------------------------------------- -! -! start time accounting for the MPI communication ! call start_timer(imc) - #ifdef PROFILE -! start time accounting for the MPI broadcast -! - call start_timer(imb) + call start_timer(imr) #endif /* PROFILE */ - call mpi_bcast(rbuf, 1, mpi_real8, 0, comm, iret) + call MPI_Recv(buf, size(buf), MPI_REAL8, src, tag, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierror) #ifdef PROFILE -! stop time accounting for the MPI broadcast -! - call stop_timer(imb) + call stop_timer(imr) #endif /* PROFILE */ - if (iret /= mpi_success .and. master) then - write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" + if (ierror /= 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 bcast_real_variable + end subroutine receive_array ! !=============================================================================== ! -! subroutine BCAST_STRING_VARIABLE: -! -------------------------------- +! subroutine EXCHANGE_ARRAYS: +! -------------------------- ! -! Subroutine broadcast a string variable from the master process to all -! other processes. +! 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; +! sbuf - the real array buffer to send; +! rbuf - the real array buffer to receive; ! !=============================================================================== ! - subroutine bcast_string_variable(sbuf, iret) + subroutine exchange_arrays(proc, tag, sbuf, rbuf) -! 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 + integer , intent(in) :: proc, tag + real(kind=8), dimension(..), intent(in) :: sbuf + real(kind=8), dimension(..), intent(in) :: rbuf -! local parameters -! - character(len=*), parameter :: loc = 'MPITOOLS::bcast_string_variable()' + integer :: ierror + + character(len=*), parameter :: loc = 'MPITOOLS::exchange_arrays()' ! !------------------------------------------------------------------------------- -! -! start time accounting for the MPI communication ! call start_timer(imc) - #ifdef PROFILE -! start time accounting for the MPI broadcast -! - call start_timer(imb) + call start_timer(ime) #endif /* PROFILE */ - call mpi_bcast(sbuf, len(sbuf), mpi_character, 0, comm, iret) + call MPI_Sendrecv(sbuf, size(sbuf), MPI_REAL8, proc, tag, & + rbuf, size(rbuf), MPI_REAL8, proc, tag, & + MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierror) #ifdef PROFILE -! stop time accounting for the MPI broadcast -! - call stop_timer(imb) + call stop_timer(ime) #endif /* PROFILE */ - if (iret /= mpi_success .and. master) then - write(error_unit,"('[', a, ']: ', a)") trim(loc), "Operation failed!" + if (ierror /= 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 bcast_string_variable + end subroutine exchange_arrays +! +!=============================================================================== +!! +!!*** PRIVATE SUBROUTINES **************************************************** +!! +!=============================================================================== ! !=============================================================================== ! -! subroutine REDUCE_MINIMUM_INTEGER: -! --------------------------------- +! subroutine REDUCE_MINIMUM_DOUBLE_ARRAY: +! -------------------------------------- ! -! Subroutine finds the minimum value among the integer values from all -! processes. +! Subroutine find the minimum value for each double precision array element +! among the corresponding values from all processes. +! +! Argument: +! +! buf - a buffer to be reduced; ! !=============================================================================== ! - subroutine reduce_minimum_integer(ibuf, iret) + subroutine reduce_minimum_double_array(buf) -! 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 + real(kind=8), dimension(:), intent(inout) :: buf -! local variables -! - integer :: tbuf + integer :: ierror + real(kind=8), dimension(size(buf)) :: tmp -! local parameters -! - character(len=*), parameter :: loc = 'MPITOOLS::reduce_minimum_integer()' + character(len=*), parameter :: loc = 'MPITOOLS::reduce_minimum_double_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, 1, mpi_integer, mpi_min, comm, iret) + call MPI_Allreduce(buf, tmp, size(buf), & + MPI_REAL8, MPI_MIN, MPI_COMM_WORLD, ierror) #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!" + if (ierror /= MPI_SUCCESS) then + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "MPI_Allreduce of a real array failed!" end if -! stop time accounting for the MPI communication -! + buf(:) = tmp(:) + 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 + end subroutine reduce_minimum_double_array ! !=============================================================================== ! @@ -761,64 +613,46 @@ module mpitools ! Subroutine find the maximum value among the integer values from all ! processes. ! +! Argument: +! +! buf - a buffer to be reduced; +! !=============================================================================== ! - subroutine reduce_maximum_integer(ibuf, iret) + subroutine reduce_maximum_integer(buf) -! 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 + integer, intent(inout) :: buf -! local variables -! - integer :: tbuf + integer :: ierror + integer :: tmp -! 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) + call MPI_Allreduce(buf, tmp, 1, & + MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierror) #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!" + if (ierror /= MPI_SUCCESS) then + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "MPI_Allreduce of an integer value failed!" end if -! stop time accounting for the MPI communication -! + buf = tmp + call stop_timer(imc) !------------------------------------------------------------------------------- @@ -827,362 +661,110 @@ module mpitools ! !=============================================================================== ! -! subroutine REDUCE_MAXIMUM_REAL: -! ------------------------------ +! subroutine REDUCE_MAXIMUM_DOUBLE: +! -------------------------------- ! -! Subroutine find the maximum value among the values from all processes. +! Subroutine find the maximum value among the double precision values +! from all processes. +! +! Argument: +! +! buf - a buffer to be reduced; ! !=============================================================================== ! - subroutine reduce_maximum_real(rbuf, iret) + subroutine reduce_maximum_double(buf) -! 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 + real(kind=8), intent(inout) :: buf -! local variables -! - real(kind=8) :: tbuf + integer :: ierror + real(kind=8) :: tmp -! local parameters -! - character(len=*), parameter :: loc = 'MPITOOLS::reduce_maximum_real()' + character(len=*), parameter :: loc = 'MPITOOLS::reduce_maximum_double()' ! !------------------------------------------------------------------------------- -! -! 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) + call MPI_Allreduce(buf, tmp, 1, MPI_REAL8, MPI_MAX, MPI_COMM_WORLD, ierror) #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!" + if (ierror /= MPI_SUCCESS) then + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "MPI_Allreduce of a real value failed!" end if -! stop time accounting for the MPI communication -! + buf = tmp + call stop_timer(imc) !------------------------------------------------------------------------------- ! - end subroutine reduce_maximum_real + end subroutine reduce_maximum_double ! !=============================================================================== ! -! subroutine REDUCE_SUM_INTEGER: -! ----------------------------- +! subroutine REDUCE_MAXIMUM_DOUBLE_ARRAY: +! -------------------------------------- ! -! Subroutine finds the sum from all integer values from all processes. +! Subroutine find the maximum value for each double plrecision array element +! among the corresponding values from all processes. +! +! Argument: +! +! buf - a buffer to be reduced; ! !=============================================================================== ! - subroutine reduce_sum_integer(ibuf, iret) + subroutine reduce_maximum_double_array(buf) -! 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 + real(kind=8), dimension(:), intent(inout) :: buf -! local variables -! - integer :: tbuf + integer :: ierror + real(kind=8), dimension(size(buf)) :: tmp -! local parameters -! - character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_integer()' + character(len=*), parameter :: loc = 'MPITOOLS::reduce_maximum_double_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, 1, mpi_integer, mpi_sum, comm, iret) + call MPI_Allreduce(buf, tmp, size(buf), & + MPI_REAL8, MPI_MAX, MPI_COMM_WORLD, ierror) #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!" + if (ierror /= MPI_SUCCESS) then + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "MPI_Allreduce of a real array failed!" end if -! stop time accounting for the MPI communication -! + buf(:) = tmp(:) + 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 + end subroutine reduce_maximum_double_array ! !=============================================================================== ! @@ -1192,65 +774,46 @@ module mpitools ! Subroutine sums the values for each array element from the corresponding ! values from all processes. ! +! Argument: +! +! buf - a buffer to be reduced; +! !=============================================================================== ! - subroutine reduce_sum_integer_array(n, ibuf, iret) + subroutine reduce_sum_integer_array(buf) -! 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 + integer, dimension(:), intent(inout) :: buf -! local variables -! - integer, dimension(n) :: tbuf + integer :: ierror + integer, dimension(size(buf)) :: tmp -! 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) + call MPI_Allreduce(buf, tmp, size(buf), & + MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierror) #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!" + if (ierror /= MPI_SUCCESS) then + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "MPI_Allreduce of an integer array failed!" end if -! stop time accounting for the MPI communication -! + buf(:) = tmp(:) + call stop_timer(imc) !------------------------------------------------------------------------------- @@ -1259,76 +822,57 @@ module mpitools ! !=============================================================================== ! -! subroutine REDUCE_SUM_REAL_ARRAY: -! -------------------------------- +! subroutine REDUCE_SUM_DOUBLE_ARRAY: +! ---------------------------------- ! -! Subroutine sums the values for each array element from the corresponding -! values from all processes. +! Subroutine sums the values for each double precision array element from +! the corresponding values from all processes. +! +! Argument: +! +! buf - a buffer to be reduced; ! !=============================================================================== ! - subroutine reduce_sum_real_array(n, rbuf, iret) + subroutine reduce_sum_double_array(buf) -! 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 + real(kind=8), dimension(:), intent(inout) :: buf -! local variables -! - real(kind=8), dimension(n) :: tbuf + integer :: ierror + real(kind=8), dimension(size(buf)) :: tmp -! local parameters -! - character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_real_array()' + character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_double_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) + call MPI_Allreduce(buf, tmp, size(buf), & + MPI_REAL8, MPI_SUM, MPI_COMM_WORLD, ierror) #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!" + if (ierror /= MPI_SUCCESS) then + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "MPI_Allreduce of a real array failed!" end if -! stop time accounting for the MPI communication -! + buf(:) = tmp(:) + call stop_timer(imc) !------------------------------------------------------------------------------- ! - end subroutine reduce_sum_real_array + end subroutine reduce_sum_double_array ! !=============================================================================== ! @@ -1338,315 +882,51 @@ module mpitools ! Subroutine sums the values for each array element from the corresponding ! complex values from all processes. ! +! Argument: +! +! buf - a buffer to be reduced; +! !=============================================================================== ! - subroutine reduce_sum_complex_array(n, cbuf, iret) + subroutine reduce_sum_complex_array(buf) -! 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 + complex(kind=8), dimension(:,:), intent(inout) :: buf -! local variables -! - complex(kind=8), dimension(n) :: tbuf + integer :: ierror + complex(kind=8), dimension(size(buf,1),size(buf,2)) :: tmp -! 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) + call MPI_Allreduce(buf, tmp, size(buf), & + MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror) #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!" + if (ierror /= MPI_SUCCESS) then + write(error_unit,"('[', a, ']: ', a)") trim(loc), & + "MPI_Allreduce of a complex array failed!" end if -! stop time accounting for the MPI communication -! + buf(:,:) = tmp(:,:) + 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 */ !=============================================================================== From 5a04b17ab30e81f0c813c64d15102885154148b2 Mon Sep 17 00:00:00 2001 From: Grzegorz Kowal Date: Fri, 14 Aug 2020 21:54:46 -0300 Subject: [PATCH 5/5] MPITOOLS: Fix compilation without MPI. Signed-off-by: Grzegorz Kowal --- sources/mpitools.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/sources/mpitools.F90 b/sources/mpitools.F90 index 8e41d20..5afed31 100644 --- a/sources/mpitools.F90 +++ b/sources/mpitools.F90 @@ -44,6 +44,7 @@ module mpitools ! subroutine interfaces ! +#ifdef MPI interface reduce_minimum module procedure reduce_minimum_double_array end interface @@ -57,6 +58,7 @@ module mpitools module procedure reduce_sum_double_array module procedure reduce_sum_complex_array end interface +#endif /* MPI */ ! timer indices ! @@ -82,9 +84,11 @@ module mpitools ! public :: initialize_mpitools, finalize_mpitools public :: check_status +#ifdef MPI public :: reduce_minimum, reduce_maximum, reduce_sum public :: send_array, receive_array public :: exchange_arrays +#endif /* MPI */ ! declare public variables !