gkowal/amun-code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into reconnection

Browse Source
This commit is contained in:
Grzegorz Kowal 2021-11-04 10:28:29 -03:00
commit c3ec26fb00
7 changed files with 252 additions and 193 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CMakeLists.txt
View File

@ -20,7 +20,7 @@ endif()
if(CMAKE_Fortran_COMPILER_ID MATCHES "GNU")
add_compile_options("$<$<CONFIG:RELEASE>:-march=native;-pipe;-fno-tree-vectorize;-fno-unsafe-math-optimizations;-frounding-math;-fsignaling-nans;-finline-limit=10000;-fdiagnostics-color=always>")
add_compile_options("$<$<CONFIG:DEBUG>:-Og;-pedantic;-W;-Wall;-Wno-unused-dummy-argument>")
add_compile_options("$<$<CONFIG:DEBUG>:-Og;-pedantic;-fcheck=all;-W;-Wall;-Wno-unused-dummy-argument>")
endif()
if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel")

36
build/hosts/default
View File

@ -23,7 +23,7 @@ LD = $(FC)
# compiler and linker flags
#
ifeq ($(DEBUG),Y)
FFLAGS = -Og -g -DDEBUG
FFLAGS = -Og -g -DDEBUG -fcheck=all
else
FFLAGS = -O2 -march=native -pipe
endif
@ -37,6 +37,38 @@ endif
endif
#-------------------------------------------------------------------------------
#
# NVIDIA Fortran compiler
#
ifeq ($(COMPILER), NVIDIA)
# compiler and linker setup
#
ifeq ($(MPI),Y)
FC = mpifort
else
FC = nvfortran
endif
LD = $(FC)
# compiler and linker flags
#
ifeq ($(DEBUG),Y)
FFLAGS = -O0 -g -Mbounds -Mchkptr -Mcache_align -Mnovintr -Mchkstk -DDEBUG
else
FFLAGS = -fast -O3
endif
ifeq ($(PROFILE),Y)
FFLAGS += -Mprof=dwarf
endif
LDFLAGS = $(FFLAGS)
ifeq ($(STATIC),Y)
LDFLAGS += -Bstatic
endif
endif
#-------------------------------------------------------------------------------
#
# PGI Fortran compiler
@ -78,7 +110,7 @@ ifeq ($(COMPILER), INTEL)
# compiler and linker setup
#
ifeq ($(MPI),Y)
FC = mpifort
FC = mpiifort
else
FC = ifort
endif

2
sources/blocks.F90
View File

@ -286,7 +286,7 @@ module blocks
! a pointer to the associated meta block
!
type(block_meta) , pointer :: block
type(block_meta) , pointer :: meta
! a pointer to the associated neighbor block
!

172
sources/boundaries.F90
View File

@ -1183,7 +1183,7 @@ module boundaries
! associate meta and data block pointers
!
pmeta => pinfo%block
pmeta => pinfo%meta
pdata => pmeta%data
! get neighbor direction and corner indices
@ -1698,12 +1698,12 @@ module boundaries
integer :: it, jt, kt
#ifdef MPI
integer :: sproc = 0, rproc = 0
integer :: scount, rcount
integer :: ecount
integer :: l, p
! local arrays
!
real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf
real(kind=8), dimension(:,:,:,:,:), allocatable :: buf
#endif /* MPI */
!
!-------------------------------------------------------------------------------
@ -1828,38 +1828,33 @@ module boundaries
!
if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then
! get sending and receiving process identifiers (depending on pair member)
! get sending and receiving process identifiers (depending on pair member),
! and the number of blocks to exchange
!
if (pairs(p,1) == nproc) then
sproc = pairs(p,1)
rproc = pairs(p,2)
ecount = bcount(sproc,rproc)
end if
if (pairs(p,2) == nproc) then
sproc = pairs(p,2)
rproc = pairs(p,1)
ecount = bcount(rproc,sproc)
end if
! get the number of blocks to exchange
!
scount = bcount(sproc,rproc)
rcount = bcount(rproc,sproc)
! process only pairs which have anything to exchange
!
if ((scount + rcount) > 0) then
if (ecount > 0) then
! allocate data buffer for variables to exchange
!
select case(idir)
case(1)
allocate(sbuf(scount,nv,ng,nh,nh))
allocate(rbuf(rcount,nv,ng,nh,nh))
allocate(buf(ecount,nv,ng,nh,nh))
case(2)
allocate(sbuf(scount,nv,nh,ng,nh))
allocate(rbuf(rcount,nv,nh,ng,nh))
allocate(buf(ecount,nv,nh,ng,nh))
case(3)
allocate(sbuf(scount,nv,nh,nh,ng))
allocate(rbuf(rcount,nv,nh,nh,ng))
allocate(buf(ecount,nv,nh,nh,ng))
end select
!! PREPARE BLOCKS FOR SENDING
@ -1904,14 +1899,11 @@ module boundaries
!
select case(idir)
case(1)
sbuf(l,1:nv,1:ng,1:nh,1:nh) = &
pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
buf(l,1:nv,1:ng,1:nh,1:nh) = pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
case(2)
sbuf(l,1:nv,1:nh,1:ng,1:nh) = &
pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
buf(l,1:nv,1:nh,1:ng,1:nh) = pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
case(3)
sbuf(l,1:nv,1:nh,1:nh,1:ng) = &
pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
buf(l,1:nv,1:nh,1:nh,1:ng) = pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
end select
! associate the pointer with the next block
@ -1924,7 +1916,7 @@ module boundaries
!!
! exchange data
!
call exchange_arrays(rproc, p, sbuf, rbuf)
call exchange_arrays(rproc, p, buf)
!! PROCESS RECEIVED BLOCKS
!!
@ -1947,7 +1939,7 @@ module boundaries
! assign a pointer to the associated data block
!
pmeta => pinfo%block
pmeta => pinfo%meta
! get the corner coordinates
!
@ -1968,11 +1960,11 @@ module boundaries
!
select case(idir)
case(1)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:nh,1:nh)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = buf(l,1:nv,1:ng,1:nh,1:nh)
case(2)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:nh,1:ng,1:nh)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = buf(l,1:nv,1:nh,1:ng,1:nh)
case(3)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:nh,1:nh,1:ng)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = buf(l,1:nv,1:nh,1:nh,1:ng)
end select
! associate the pointer with the next block
@ -1983,9 +1975,9 @@ module boundaries
! deallocate data buffer
!
deallocate(sbuf, rbuf)
deallocate(buf)
end if ! (scount + rcount) > 0
end if ! ecount > 0
end if ! pairs(p,1) == nproc || pairs(p,2) == nproc
@ -2295,7 +2287,7 @@ module boundaries
! assign a pointer to the associated data block
!
pmeta => pinfo%block
pmeta => pinfo%meta
! get the corner coordinates
!
@ -2621,7 +2613,7 @@ module boundaries
! assign pmeta and pneigh to the right blocks
!
pmeta => pinfo%block
pmeta => pinfo%meta
pneigh => pinfo%neigh
! get the corner coordinates
@ -2687,7 +2679,7 @@ module boundaries
! assign a pointer to the associated data block
!
pmeta => pinfo%block
pmeta => pinfo%meta
! get the corner coordinates
!
@ -2835,12 +2827,12 @@ module boundaries
#endif /* NDIMS == 3 */
#ifdef MPI
integer :: sproc = 0, rproc = 0
integer :: scount, rcount
integer :: ecount
integer :: l, p
! local arrays
!
real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf
real(kind=8), dimension(:,:,:,:,:), allocatable :: buf
#endif /* MPI */
!
!-------------------------------------------------------------------------------
@ -2992,47 +2984,40 @@ module boundaries
!
if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then
! get sending and receiving process identifiers (depending on pair member)
! get sending and receiving process identifiers (depending on pair member),
! and the number of blocks to exchange
!
if (pairs(p,1) == nproc) then
sproc = pairs(p,1)
rproc = pairs(p,2)
ecount = bcount(sproc,rproc)
end if
if (pairs(p,2) == nproc) then
sproc = pairs(p,2)
rproc = pairs(p,1)
ecount = bcount(rproc,sproc)
end if
! get the number of blocks to exchange
!
scount = bcount(sproc,rproc)
rcount = bcount(rproc,sproc)
! process only pairs which have anything to exchange
!
if ((scount + rcount) > 0) then
if (ecount > 0) then
! allocate buffers for variable exchange
!
select case(idir)
#if NDIMS == 2
case(1)
allocate(sbuf(scount,nv,nh,ng, 1))
allocate(rbuf(rcount,nv,nh,ng, 1))
allocate(buf(ecount,nv,nh,ng, 1))
case(2)
allocate(sbuf(scount,nv,ng,nh, 1))
allocate(rbuf(rcount,nv,ng,nh, 1))
allocate(buf(ecount,nv,ng,nh, 1))
#endif /* NDIMS == 2 */
#if NDIMS == 3
case(1)
allocate(sbuf(scount,nv,nh,ng,ng))
allocate(rbuf(rcount,nv,nh,ng,ng))
allocate(buf(ecount,nv,nh,ng,ng))
case(2)
allocate(sbuf(scount,nv,ng,nh,ng))
allocate(rbuf(rcount,nv,ng,nh,ng))
allocate(buf(ecount,nv,ng,nh,ng))
case(3)
allocate(sbuf(scount,nv,ng,ng,nh))
allocate(rbuf(rcount,nv,ng,ng,nh))
allocate(buf(ecount,nv,ng,ng,nh))
#endif /* NDIMS == 3 */
end select
@ -3089,26 +3074,21 @@ module boundaries
select case(idir)
case(1)
#if NDIMS == 2
sbuf(l,1:nv,1:nh,1:ng, : ) = &
pneigh%data%q(1:nv,is:it,js:jt, : )
buf(l,1:nv,1:nh,1:ng, : ) = pneigh%data%q(1:nv,is:it,js:jt, : )
#endif /* NDIMS == 2 */
#if NDIMS == 3
sbuf(l,1:nv,1:nh,1:ng,1:ng) = &
pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
buf(l,1:nv,1:nh,1:ng,1:ng) = pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
#endif /* NDIMS == 3 */
case(2)
#if NDIMS == 2
sbuf(l,1:nv,1:ng,1:nh, : ) = &
pneigh%data%q(1:nv,is:it,js:jt, : )
buf(l,1:nv,1:ng,1:nh, : ) = pneigh%data%q(1:nv,is:it,js:jt, : )
#endif /* NDIMS == 2 */
#if NDIMS == 3
sbuf(l,1:nv,1:ng,1:nh,1:ng) = &
pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
buf(l,1:nv,1:ng,1:nh,1:ng) = pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
#endif /* NDIMS == 3 */
#if NDIMS == 3
case(3)
sbuf(l,1:nv,1:ng,1:ng,1:nh) = &
pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
buf(l,1:nv,1:ng,1:ng,1:nh) = pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
#endif /* NDIMS == 3 */
end select
@ -3122,7 +3102,7 @@ module boundaries
!!
! exchange data
!
call exchange_arrays(rproc, p, sbuf, rbuf)
call exchange_arrays(rproc, p, buf)
!! PROCESS RECEIVED BLOCKS
!!
@ -3145,7 +3125,7 @@ module boundaries
! assign a pointer to the associated data block
!
pmeta => pinfo%block
pmeta => pinfo%meta
! get the corner coordinates
!
@ -3177,21 +3157,21 @@ module boundaries
select case(idir)
case(1)
#if NDIMS == 2
pmeta%data%q(1:nv,il:iu,jl:ju, : ) = rbuf(l,1:nv,1:nh,1:ng, : )
pmeta%data%q(1:nv,il:iu,jl:ju, : ) = buf(l,1:nv,1:nh,1:ng, : )
#endif /* NDIMS == 2 */
#if NDIMS == 3
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:nh,1:ng,1:ng)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = buf(l,1:nv,1:nh,1:ng,1:ng)
#endif /* NDIMS == 3 */
case(2)
#if NDIMS == 2
pmeta%data%q(1:nv,il:iu,jl:ju, : ) = rbuf(l,1:nv,1:ng,1:nh, : )
pmeta%data%q(1:nv,il:iu,jl:ju, : ) = buf(l,1:nv,1:ng,1:nh, : )
#endif /* NDIMS == 2 */
#if NDIMS == 3
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:nh,1:ng)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = buf(l,1:nv,1:ng,1:nh,1:ng)
#endif /* NDIMS == 3 */
#if NDIMS == 3
case(3)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:ng,1:nh)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = buf(l,1:nv,1:ng,1:ng,1:nh)
#endif /* NDIMS == 3 */
end select
@ -3203,9 +3183,9 @@ module boundaries
! deallocate data buffer
!
deallocate(sbuf, rbuf)
deallocate(buf)
end if ! (scount + rcount) > 0
end if ! ecount > 0
end if ! pairs(p,1) == nproc || pairs(p,2) == nproc
@ -3569,7 +3549,7 @@ module boundaries
! assign a pointer to the associated data block
!
pmeta => pinfo%block
pmeta => pinfo%meta
! get the corner coordinates
!
@ -3966,7 +3946,7 @@ module boundaries
! assign pmeta and pneigh to the associated blocks
!
pmeta => pinfo%block
pmeta => pinfo%meta
pneigh => pinfo%neigh
! get the corner coordinates
@ -4047,7 +4027,7 @@ module boundaries
! assign a pointer to the associated data block
!
pmeta => pinfo%block
pmeta => pinfo%meta
! get the corner coordinates
!
@ -4214,12 +4194,12 @@ module boundaries
#endif /* NDIMS == 3 */
#ifdef MPI
integer :: sproc = 0, rproc = 0
integer :: scount, rcount
integer :: ecount
integer :: l, p
! local arrays
!
real(kind=8), dimension(:,:,:,:,:), allocatable :: sbuf, rbuf
real(kind=8), dimension(:,:,:,:,:), allocatable :: buf
#endif /* MPI */
!
!-------------------------------------------------------------------------------
@ -4371,35 +4351,31 @@ module boundaries
!
if (pairs(p,1) == nproc .or. pairs(p,2) == nproc) then
! get sending and receiving process identifiers (depending on pair member)
! get sending and receiving process identifiers (depending on pair member),
! and the number of blocks to exchange
!
if (pairs(p,1) == nproc) then
sproc = pairs(p,1)
rproc = pairs(p,2)
ecount = bcount(sproc,rproc)
end if
if (pairs(p,2) == nproc) then
sproc = pairs(p,2)
rproc = pairs(p,1)
ecount = bcount(rproc,sproc)
end if
! get the number of blocks to exchange
!
scount = bcount(sproc,rproc)
rcount = bcount(rproc,sproc)
! process only pairs which have anything to exchange
!
if ((scount + rcount) > 0) then
if (ecount > 0) then
! allocate buffers for variable exchange
!
#if NDIMS == 2
allocate(sbuf(scount,nv,ng,ng, 1))
allocate(rbuf(rcount,nv,ng,ng, 1))
allocate(buf(ecount,nv,ng,ng, 1))
#endif /* NDIMS == 2 */
#if NDIMS == 3
allocate(sbuf(scount,nv,ng,ng,ng))
allocate(rbuf(rcount,nv,ng,ng,ng))
allocate(buf(ecount,nv,ng,ng,ng))
#endif /* NDIMS == 3 */
!! PREPARE BLOCKS FOR SENDING
@ -4452,10 +4428,10 @@ module boundaries
! copy the corresponding corner region from the neighbor to the buffer
!
#if NDIMS == 2
sbuf(l,1:nv,1:ng,1:ng, : ) = pneigh%data%q(1:nv,is:it,js:jt, : )
buf(l,1:nv,1:ng,1:ng, : ) = pneigh%data%q(1:nv,is:it,js:jt, : )
#endif /* NDIMS == 2 */
#if NDIMS == 3
sbuf(l,1:nv,1:ng,1:ng,1:ng) = pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
buf(l,1:nv,1:ng,1:ng,1:ng) = pneigh%data%q(1:nv,is:it,js:jt,ks:kt)
#endif /* NDIMS == 3 */
! associate the pointer with the next block
@ -4468,7 +4444,7 @@ module boundaries
!!
! exchange data
!
call exchange_arrays(rproc, p, sbuf, rbuf)
call exchange_arrays(rproc, p, buf)
!! PROCESS RECEIVED BLOCKS
!!
@ -4491,7 +4467,7 @@ module boundaries
! assign a pointer to the associated data block
!
pmeta => pinfo%block
pmeta => pinfo%meta
! get the corner coordinates
!
@ -4521,10 +4497,10 @@ module boundaries
! update the corresponding corner region of the current block
!
#if NDIMS == 2
pmeta%data%q(1:nv,il:iu,jl:ju, : ) = rbuf(l,1:nv,1:ng,1:ng, : )
pmeta%data%q(1:nv,il:iu,jl:ju, : ) = buf(l,1:nv,1:ng,1:ng, : )
#endif /* NDIMS == 2 */
#if NDIMS == 3
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = rbuf(l,1:nv,1:ng,1:ng,1:ng)
pmeta%data%q(1:nv,il:iu,jl:ju,kl:ku) = buf(l,1:nv,1:ng,1:ng,1:ng)
#endif /* NDIMS == 3 */
! associate the pointer with the next block
@ -4535,9 +4511,9 @@ module boundaries
! deallocate data buffer
!
deallocate(sbuf, rbuf)
deallocate(buf)
end if ! (scount + rcount) > 0
end if ! ecount > 0
end if ! pairs(p,1) == nproc || pairs(p,2) == nproc
@ -4860,7 +4836,7 @@ module boundaries
! assign a pointer to the associated data block
!
pmeta => pinfo%block
pmeta => pinfo%meta
! get the corner coordinates
!
@ -5229,7 +5205,7 @@ module boundaries
! assign a pointer to the associated data block
!
pmeta => pinfo%block
pmeta => pinfo%meta
! get the corner coordinates
!
@ -6911,7 +6887,7 @@ module boundaries
!
nullify(pinfo%prev)
nullify(pinfo%next)
nullify(pinfo%block)
nullify(pinfo%meta)
nullify(pinfo%neigh)
! deallocate info block
@ -6990,7 +6966,7 @@ module boundaries
! fill out its fields
!
pinfo%block => pmeta
pinfo%meta => pmeta
pinfo%neigh => pneigh
pinfo%direction = dir
pinfo%corner(1:NDIMS) = pos(1:NDIMS)

2
sources/equations.F90
View File

@ -5528,7 +5528,6 @@ module equations
, "N = ", nr
write(error_unit,"('[',a,']: ',a,4(1es24.16))") trim(loc) &
, "X = ", x(1:4)
iret = 300
end if
#endif /* DEBUG */
@ -5549,7 +5548,6 @@ module equations
, "N = ", nr
write(error_unit,"('[',a,']: ',a,4(1es24.16))") trim(loc) &
, "X = ", x(1:4)
iret = 300
#endif /* DEBUG */
end if

15
sources/mesh.F90
View File

@ -506,7 +506,7 @@ module mesh
type(block_meta), pointer :: pmeta
type(block_data), pointer :: pdata
logical :: refine
logical :: refine, flag
integer(kind=4) :: level, lev
integer(kind=4) :: nc, nr, np, nl
@ -739,13 +739,17 @@ module mesh
nr = 1
nc = nc + 1
end if
do while(lb(nr,nc) == 0 .and. nc <= nodes)
flag = nc <= nodes
if (flag) flag = lb(nr,nc) == 0
do while(flag)
np = min(npmax, np + 1)
nr = nr + 1
if (nr > lprocs) then
nr = 1
nc = nc + 1
end if
flag = nc <= nodes
if (flag) flag = lb(nr,nc) == 0
end do
end if ! nl >= lb(nr,np)
@ -912,6 +916,7 @@ module mesh
#ifdef MPI
! local variables
!
logical :: flag
integer :: status
integer(kind=4) :: np, nl, nc, nr
@ -1063,13 +1068,17 @@ module mesh
nr = 1
nc = nc + 1
end if
do while(lb(nr,nc) == 0 .and. nc <= nodes)
flag = nc <= nodes
if (flag) flag = lb(nr,nc) == 0
do while(flag)
np = min(npmax, np + 1)
nr = nr + 1
if (nr > lprocs) then
nr = 1
nc = nc + 1
end if
flag = nc <= nodes
if (flag) flag = lb(nr,nc) == 0
end do
end if ! nl >= lb(nr,np)

164
sources/mpitools.F90
View File

@ -50,7 +50,9 @@ module mpitools
end interface
interface reduce_maximum
module procedure reduce_maximum_integer
#ifndef __NVCOMPILER
module procedure reduce_maximum_double
#endif /* __NVCOMPILER */
module procedure reduce_maximum_double_array
end interface
interface reduce_sum
@ -58,6 +60,10 @@ module mpitools
module procedure reduce_sum_double_array
module procedure reduce_sum_complex_array
end interface
interface exchange_arrays
module procedure exchange_arrays_diff
module procedure exchange_arrays_same
end interface
#endif /* MPI */
! timer indices
@ -357,65 +363,51 @@ module mpitools
!
! Arguments:
!
! ibuf - the logical buffer;
! flag - the input logical flag;
!
!===============================================================================
!
logical function check_status(ibuf) result(obuf)
logical function check_status(flag)
! include external procedures and variables
!
use iso_fortran_env, only : error_unit
! local variables are not implicit by default
!
implicit none
! subroutine arguments
!
logical, intent(in) :: ibuf
logical, intent(in) :: flag
#ifdef MPI
! local variables
!
integer :: ierror
! local parameters
!
character(len=*), parameter :: loc = 'MPITOOLS::check_status()'
#endif /* MPI */
!
!-------------------------------------------------------------------------------
!
#ifdef MPI
call start_timer(imc)
#ifdef PROFILE
call start_timer(imm)
#endif /* PROFILE */
call MPI_Allreduce(ibuf, obuf, 1, &
check_status = flag
#ifdef MPI
call MPI_Allreduce(MPI_IN_PLACE, check_status, 1, &
MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ierror)
if (ierror /= MPI_SUCCESS) then
write(error_unit,"('[', a, ']: ', a)") trim(loc), &
"MPI_Allreduce of logical buffer failed!"
end if
#endif /* MPI */
#ifdef PROFILE
call stop_timer(imm)
#endif /* PROFILE */
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
!
!===============================================================================
@ -525,10 +517,11 @@ module mpitools
!
!===============================================================================
!
! subroutine EXCHANGE_ARRAYS:
! --------------------------
! subroutine EXCHANGE_ARRAYS_DIFF:
! -------------------------------
!
! Subroutine exchanges real data buffers between two processes.
! Subroutine exchanges real data buffers (of different sizes) between
! two processes.
!
! Arguments:
!
@ -540,7 +533,7 @@ module mpitools
!
!===============================================================================
!
subroutine exchange_arrays(proc, tag, sbuf, rbuf)
subroutine exchange_arrays_diff(proc, tag, sbuf, rbuf)
use iso_fortran_env, only : error_unit
@ -548,11 +541,12 @@ module mpitools
integer , intent(in) :: proc, tag
real(kind=8), dimension(..), intent(in) :: sbuf
real(kind=8), dimension(..), intent(in) :: rbuf
real(kind=8), dimension(..), intent(out) :: rbuf
integer :: ssize, rsize
integer :: ierror
character(len=*), parameter :: loc = 'MPITOOLS::exchange_arrays()'
character(len=*), parameter :: loc = 'MPITOOLS::exchange_arrays_diff()'
!
!-------------------------------------------------------------------------------
!
@ -561,9 +555,22 @@ module mpitools
call start_timer(ime)
#endif /* PROFILE */
call MPI_Sendrecv(sbuf, size(sbuf), MPI_REAL8, proc, tag, &
rbuf, size(rbuf), MPI_REAL8, proc, tag, &
ssize = size(sbuf)
rsize = size(rbuf)
if (ssize > 0 .and. rsize > 0) then
call MPI_Sendrecv(sbuf, ssize, MPI_REAL8, proc, tag, &
rbuf, rsize, MPI_REAL8, proc, tag, &
MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierror)
else
if (ssize > 0) then
call MPI_Send(sbuf, ssize, MPI_REAL8, proc, tag, MPI_COMM_WORLD, &
ierror)
else
call MPI_Recv(rbuf, rsize, MPI_REAL8, proc, tag, MPI_COMM_WORLD, &
MPI_STATUS_IGNORE, ierror)
end if
end if
#ifdef PROFILE
call stop_timer(ime)
@ -579,7 +586,62 @@ module mpitools
!-------------------------------------------------------------------------------
!
end subroutine exchange_arrays
end subroutine exchange_arrays_diff
!
!===============================================================================
!
! subroutine EXCHANGE_ARRAYS_SAME:
! -------------------------------
!
! Subroutine exchanges a real data buffer 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;
! buf - the real array buffer to exchange;
!
!===============================================================================
!
subroutine exchange_arrays_same(proc, tag, buf)
use iso_fortran_env, only : error_unit
implicit none
integer , intent(in) :: proc, tag
real(kind=8), dimension(..), intent(inout) :: buf
integer :: ierror
character(len=*), parameter :: loc = 'MPITOOLS::exchange_arrays_same()'
!
!-------------------------------------------------------------------------------
!
call start_timer(imc)
#ifdef PROFILE
call start_timer(ime)
#endif /* PROFILE */
call MPI_Sendrecv_replace(buf, size(buf), MPI_REAL8, proc, tag, proc, tag, &
MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierror)
#ifdef PROFILE
call stop_timer(ime)
#endif /* PROFILE */
if (ierror /= MPI_SUCCESS) then
write(error_unit,"('[', a, ']: ', 2(a, i9),'.')") trim(loc) &
, "Could not exchange real data buffer between " &
, proc, "and", nproc
end if
call stop_timer(imc)
!-------------------------------------------------------------------------------
!
end subroutine exchange_arrays_same
!
!===============================================================================
!!
@ -610,7 +672,6 @@ module mpitools
real(kind=8), dimension(:), intent(inout) :: buf
integer :: ierror
real(kind=8), dimension(size(buf)) :: tmp
character(len=*), parameter :: loc = 'MPITOOLS::reduce_minimum_double_array()'
!
@ -621,7 +682,7 @@ module mpitools
call start_timer(imm)
#endif /* PROFILE */
call MPI_Allreduce(buf, tmp, size(buf), &
call MPI_Allreduce(MPI_IN_PLACE, buf, size(buf), &
MPI_REAL8, MPI_MIN, MPI_COMM_WORLD, ierror)
#ifdef PROFILE
@ -633,8 +694,6 @@ module mpitools
"MPI_Allreduce of a real array failed!"
end if
buf(:) = tmp(:)
call stop_timer(imc)
!-------------------------------------------------------------------------------
@ -664,7 +723,6 @@ module mpitools
integer, intent(inout) :: buf
integer :: ierror
integer :: tmp
character(len=*), parameter :: loc = 'MPITOOLS::reduce_maximum_integer()'
!
@ -675,7 +733,7 @@ module mpitools
call start_timer(imm)
#endif /* PROFILE */
call MPI_Allreduce(buf, tmp, 1, &
call MPI_Allreduce(MPI_IN_PLACE, buf, 1, &
MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierror)
#ifdef PROFILE
@ -687,13 +745,12 @@ module mpitools
"MPI_Allreduce of an integer value failed!"
end if
buf = tmp
call stop_timer(imc)
!-------------------------------------------------------------------------------
!
end subroutine reduce_maximum_integer
#ifndef __NVCOMPILER
!
!===============================================================================
!
@ -718,7 +775,6 @@ module mpitools
real(kind=8), intent(inout) :: buf
integer :: ierror
real(kind=8) :: tmp
character(len=*), parameter :: loc = 'MPITOOLS::reduce_maximum_double()'
!
@ -729,7 +785,8 @@ module mpitools
call start_timer(imm)
#endif /* PROFILE */
call MPI_Allreduce(buf, tmp, 1, MPI_REAL8, MPI_MAX, MPI_COMM_WORLD, ierror)
call MPI_Allreduce(MPI_IN_PLACE, buf, 1, &
MPI_REAL8, MPI_MAX, MPI_COMM_WORLD, ierror)
#ifdef PROFILE
call stop_timer(imm)
@ -740,13 +797,12 @@ module mpitools
"MPI_Allreduce of a real value failed!"
end if
buf = tmp
call stop_timer(imc)
!-------------------------------------------------------------------------------
!
end subroutine reduce_maximum_double
#endif /* __NVCOMPILER */
!
!===============================================================================
!
@ -771,7 +827,6 @@ module mpitools
real(kind=8), dimension(:), intent(inout) :: buf
integer :: ierror
real(kind=8), dimension(size(buf)) :: tmp
character(len=*), parameter :: loc = 'MPITOOLS::reduce_maximum_double_array()'
!
@ -782,7 +837,7 @@ module mpitools
call start_timer(imm)
#endif /* PROFILE */
call MPI_Allreduce(buf, tmp, size(buf), &
call MPI_Allreduce(MPI_IN_PLACE, buf, size(buf), &
MPI_REAL8, MPI_MAX, MPI_COMM_WORLD, ierror)
#ifdef PROFILE
@ -794,8 +849,6 @@ module mpitools
"MPI_Allreduce of a real array failed!"
end if
buf(:) = tmp(:)
call stop_timer(imc)
!-------------------------------------------------------------------------------
@ -825,7 +878,6 @@ module mpitools
integer, dimension(:), intent(inout) :: buf
integer :: ierror
integer, dimension(size(buf)) :: tmp
character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_integer_array()'
!
@ -836,7 +888,7 @@ module mpitools
call start_timer(imm)
#endif /* PROFILE */
call MPI_Allreduce(buf, tmp, size(buf), &
call MPI_Allreduce(MPI_IN_PLACE, buf, size(buf), &
MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierror)
#ifdef PROFILE
@ -848,8 +900,6 @@ module mpitools
"MPI_Allreduce of an integer array failed!"
end if
buf(:) = tmp(:)
call stop_timer(imc)
!-------------------------------------------------------------------------------
@ -879,7 +929,6 @@ module mpitools
real(kind=8), dimension(:), intent(inout) :: buf
integer :: ierror
real(kind=8), dimension(size(buf)) :: tmp
character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_double_array()'
!
@ -890,7 +939,7 @@ module mpitools
call start_timer(imm)
#endif /* PROFILE */
call MPI_Allreduce(buf, tmp, size(buf), &
call MPI_Allreduce(MPI_IN_PLACE, buf, size(buf), &
MPI_REAL8, MPI_SUM, MPI_COMM_WORLD, ierror)
#ifdef PROFILE
@ -902,8 +951,6 @@ module mpitools
"MPI_Allreduce of a real array failed!"
end if
buf(:) = tmp(:)
call stop_timer(imc)
!-------------------------------------------------------------------------------
@ -933,7 +980,6 @@ module mpitools
complex(kind=8), dimension(:,:), intent(inout) :: buf
integer :: ierror
complex(kind=8), dimension(size(buf,1),size(buf,2)) :: tmp
character(len=*), parameter :: loc = 'MPITOOLS::reduce_sum_complex_array()'
!
@ -944,7 +990,7 @@ module mpitools
call start_timer(imm)
#endif /* PROFILE */
call MPI_Allreduce(buf, tmp, size(buf), &
call MPI_Allreduce(MPI_IN_PLACE, buf, size(buf), &
MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror)
#ifdef PROFILE
@ -956,8 +1002,6 @@ module mpitools
"MPI_Allreduce of a complex array failed!"
end if
buf(:,:) = tmp(:,:)
call stop_timer(imc)
!-------------------------------------------------------------------------------