!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
module global_reductions 17,20
!BOP
! !MODULE: global_reductions
! !DESCRIPTION:
! This module contains all the routines for performing global
! reductions like global sums, minvals, maxvals, etc.
!
! !REVISION HISTORY:
! SVN:$Id: global_reductions.F90 7735 2007-11-28 22:56:48Z njn01 $
! !USES:
use kinds_mod
use communicate
use constants
use blocks
use distribution
use domain_size
use domain
use exit_mod
use registry
!use timers
implicit none
private
save
! !PUBLIC MEMBER FUNCTIONS:
public :: global_sum, &
global_sum_prod, &
global_count, &
global_maxval, &
global_minval, &
global_maxloc, &
init_global_reductions
!EOP
!BOC
!-----------------------------------------------------------------------
!
! generic interfaces for module procedures
!
!-----------------------------------------------------------------------
interface global_sum
module procedure global_sum_nfields_dbl
global_sum_dbl, &
global_sum_real, &
global_sum_int, &
global_sum_scalar_dbl, &
global_sum_scalar_real, &
global_sum_scalar_int
end interface
interface global_sum_prod
module procedure global_sum_prod_dbl
global_sum_prod_real, &
global_sum_prod_int
end interface
interface global_count
module procedure global_count_dbl
global_count_real, &
global_count_int, &
global_count_log
end interface
interface global_maxval
module procedure global_maxval_dbl
global_maxval_real, &
global_maxval_int, &
global_maxval_scalar_dbl, &
global_maxval_scalar_real, &
global_maxval_scalar_int
end interface
interface global_minval
module procedure global_minval_dbl
global_minval_real, &
global_minval_int, &
global_minval_scalar_dbl, &
global_minval_scalar_real, &
global_minval_scalar_int
end interface
interface global_maxloc
module procedure global_maxloc_dbl
global_maxloc_real, &
global_maxloc_int
end interface
!-----------------------------------------------------------------------
!
! module variables
!
!-----------------------------------------------------------------------
!integer (int_kind) :: timer_local, timer_mpi
logical (log_kind) :: b4b
!EOC
!***********************************************************************
contains
!***********************************************************************
!BOP
! !IROUTINE: init_global_reductions
! !INTERFACE:
subroutine init_global_reductions 2,2
! !DESCRIPTION:
! Initializes necessary buffers for global reductions.
!
! !REVISION HISTORY:
! same as module
!EOP
!BOC
!-----------------------------------------------------------------------
!call get_timer(timer_local, 'SUM_LOCAL')
!call get_timer(timer_mpi , 'SUM_MPI')
b4b = registry_match('b4b_flag')
if (b4b .and. ltripole_grid) &
call exit_POP(SigAbort,'(global_sum_dbl) b4b is incompatible with tripole grid')
!-----------------------------------------------------------------------
!EOC
end subroutine init_global_reductions
!***********************************************************************
!BOP
! !IROUTINE: global_sum
! !INTERFACE:
function global_sum_nfields_dbl(X, dist, field_loc, MASK) 1,2
! !DESCRIPTION:
! computes the global sums of the physical domain of a set of 2-d
! arrays.
!
! !REVISION HISTORY:
! same as module
!
! !REMARKS:
! This is actually the specific interface for the generic global_sum
! function corresponding to a set of double precision 2d arrays.
! !USES:
include 'mpif.h' ! MPI Fortran include file
! !INPUT PARAMETERS:
real (r8), dimension(:,:,:,:), intent(in) :: &
X ! array to be summed
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
real (r8), dimension(size(X,dim=1), &
size(X,dim=2), &
size(X,dim=4)), intent(in), optional :: &
MASK ! real 2d multiplicative mask
! !OUTPUT PARAMETERS:
real (r8), dimension(size(X,dim=3)) :: &
global_sum_nfields_dbl ! resulting global sum
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r8), dimension(:), allocatable :: &
local_sum ! sum of all local blocks
integer (int_kind) :: &
i,j,k,n, &! local counters
nfields, &! number of 2d fields for which sum is req
ib,ie,jb,je, &! beg,end of physical domain
bid, &! block location
ierr ! MPI error flag
type (block) :: &
this_block ! holds local block information
!-----------------------------------------------------------------------
!
! use this code for sums that are not reproducible for best performance
!
!-----------------------------------------------------------------------
nfields = size(X,dim=3)
allocate(local_sum(nfields))
local_sum = c0
!call timer_start(timer_local)
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
if (present(MASK)) then
do k=1,nfields
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum(k) = local_sum(k) + X(i,je,k,bid)*MASK(i,je,bid)
end do
end do
else ! no mask
do k=1,nfields
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum(k) = local_sum(k) + X(i,je,k,bid)
end do
end do
endif
je = je - 1
endif
if (present(MASK)) then
do k=1,nfields
do j=jb,je
do i=ib,ie
local_sum(k) = local_sum(k) + X(i,j,k,bid)*MASK(i,j,bid)
end do
end do
end do
else ! no mask
do k=1,nfields
do j=jb,je
do i=ib,ie
local_sum(k) = local_sum(k) + X(i,j,k,bid)
end do
end do
end do
endif
endif
end do !block loop
else ! regular global sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(MASK)) then
do k=1,nfields
do j=jb,je
do i=ib,ie
local_sum(k) = local_sum(k) + X(i,j,k,bid)*MASK(i,j,bid)
end do
end do
end do
else ! no mask
do k=1,nfields
do j=jb,je
do i=ib,ie
local_sum(k) = local_sum(k) + X(i,j,k,bid)
end do
end do
end do
endif
endif
end do !block loop
endif
!call timer_stop(timer_local)
!call timer_start(timer_mpi)
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_sum, global_sum_nfields_dbl, nfields, &
mpi_dbl, MPI_SUM, dist%communicator, ierr)
else
global_sum_nfields_dbl = c0
endif
else
global_sum_nfields_dbl = local_sum
endif
!call timer_stop(timer_mpi)
deallocate(local_sum)
!-----------------------------------------------------------------------
!
! use this code for sums that are more reproducible - performance
! of this code does not scale well for large numbers of blocks
! NOTE: THIS CODE NOT MODIFIED FOR TRIPOLE GRIDS YET
!
!-----------------------------------------------------------------------
!
! allocate (local_block_sum(nblocks_tot), &
! global_block_sum(nblocks_tot))
!
! local_block_sum = c0
!
! !call timer_start(timer_local)
! if (present(MASK)) then
! do n=1,nblocks_tot
! if (dist%proc(n) == my_task+1) then
! bid = dist%local_block(n)
! call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
! do j=jb,je
! do i=ib,ie
! local_block_sum(n) = &
! local_block_sum(n) + X(i,j,bid)*MASK(i,j,bid)
! end do
! end do
! endif
! end do
! else
! do n=1,nblocks_tot
! if (dist%proc(n) == my_task+1) then
! bid = dist%local_block(n)
! call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
! do j=jb,je
! do i=ib,ie
! local_block_sum(n) = &
! local_block_sum(n) + X(i,j,bid)
! end do
! end do
! endif
! end do
! endif
! !call timer_stop(timer_local)
!
! !call timer_start(timer_mpi)
! call MPI_ALLREDUCE(local_block_sum, global_block_sum, nblocks_tot, &
! mpi_dbl, MPI_SUM, dist%communicator, ierr)
! !call timer_stop(timer_mpi)
!
! global_sum_dbl = c0
! do n=1,nblocks_tot
! global_sum_dbl = global_sum_dbl + global_block_sum(n)
! end do
!
! deallocate ( local_block_sum, global_block_sum)
!
!-----------------------------------------------------------------------
end function global_sum_nfields_dbl
!***********************************************************************
!BOP
! !IROUTINE: global_sum
! !INTERFACE:
function global_sum_dbl(X, dist, field_loc, MASK) 1,7
! !DESCRIPTION:
! computes the global sum of the _physical domain_ of a 2-d
! array.
!
! !REVISION HISTORY:
! same as module
!
! !REMARKS:
! This is actually the specific interface for the generic global_sum
! function corresponding to double precision arrays. The generic
! interface is identical but will handle real and integer 2-d slabs
! and real, integer, and double precision scalars.
! !USES:
include 'mpif.h' ! MPI Fortran include file
! !INPUT PARAMETERS:
real (r8), dimension(:,:,:), intent(in) :: &
X ! array to be summed
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
real (r8), dimension(size(X,dim=1), &
size(X,dim=2), &
size(X,dim=3)), intent(in), optional :: &
MASK ! real multiplicative mask
! !OUTPUT PARAMETERS:
real (r8) :: &
global_sum_dbl ! resulting global sum
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r8), dimension(:), allocatable :: &
local_block_sum, &! sum of local blocks
global_block_sum ! sum of all blocks
real (r8) :: &
local_sum ! sum of all local blocks
integer (int_kind) :: &
i,j,n, &! local counters
ib,ie,jb,je, &! beg,end of physical domain
bid, &! block location
ierr ! MPI error flag
type (block) :: &
this_block ! holds local block information
if (.not. b4b) then
!-----------------------------------------------------------------------
!
! use this code for sums that are not reproducible for best performance
!
!-----------------------------------------------------------------------
local_sum = c0
!call timer_start(timer_local)
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
if (present(MASK)) then
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + X(i,je,bid)*MASK(i,je,bid)
end do
else ! no mask
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + X(i,je,bid)
end do
endif
je = je - 1
endif
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)
end do
end do
endif
endif
end do !block loop
else ! regular global sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)
end do
end do
endif
endif
end do !block loop
endif
!call timer_stop(timer_local)
!call timer_start(timer_mpi)
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_sum, global_sum_dbl, 1, &
mpi_dbl, MPI_SUM, dist%communicator, ierr)
else
global_sum_dbl = c0
endif
else
global_sum_dbl = local_sum
endif
!call timer_stop(timer_mpi)
else !b4b
!-----------------------------------------------------------------------
!
! use this code for sums that are more reproducible - performance
! of this code does not scale well for large numbers of blocks
! NOTE: THIS CODE NOT MODIFIED FOR TRIPOLE GRIDS YET
!
!-----------------------------------------------------------------------
allocate (local_block_sum(nblocks_tot), &
global_block_sum(nblocks_tot))
local_block_sum = c0
!call timer_start(timer_local)
if (present(MASK)) then
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)*MASK(i,j,bid)
end do
end do
endif
end do
else
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)
end do
end do
endif
end do
endif
!call timer_stop(timer_local)
!call timer_start(timer_mpi)
call MPI_ALLREDUCE(local_block_sum, global_block_sum, nblocks_tot, &
mpi_dbl, MPI_SUM, dist%communicator, ierr)
!call timer_stop(timer_mpi)
global_sum_dbl = c0
do n=1,nblocks_tot
global_sum_dbl = global_sum_dbl + global_block_sum(n)
end do
deallocate ( local_block_sum, global_block_sum)
endif ! b4b
!-----------------------------------------------------------------------
end function global_sum_dbl
!***********************************************************************
function global_sum_real(X, dist, field_loc, MASK),7
!-----------------------------------------------------------------------
!
! computes the global sum of the _physical domain_ of a 2-d
! array.
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
!-----------------------------------------------------------------------
!
! input vars
!
!-----------------------------------------------------------------------
real (r4), dimension(:,:,:), intent(in) :: &
X ! array to be summed
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
real (r8), dimension(size(X,dim=1), &
size(X,dim=2), &
size(X,dim=3)), intent(in), optional :: &
MASK ! real multiplicative mask
!-----------------------------------------------------------------------
!
! output result
!
!-----------------------------------------------------------------------
real (r4) :: &
global_sum_real ! resulting global sum
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r4), dimension(:), allocatable :: &
local_block_sum, &! sum of local blocks
global_block_sum ! sum of all blocks
real (r4) :: &
local_sum ! sum of local blocks
integer (int_kind) :: &
i,j,n, &! local counters
ib,ie,jb,je, &! beg,end of physical domain
bid, &! block location
ierr ! MPI error flag
type (block) :: &
this_block ! holds local block information
if (.not. b4b) then
!-----------------------------------------------------------------------
!
! use this code for sums that perform better but are not reproducible
!
!-----------------------------------------------------------------------
local_sum = c0
!call timer_start(timer_local)
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
if (present(MASK)) then
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + X(i,je,bid)*MASK(i,je,bid)
end do
else ! no mask
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + X(i,je,bid)
end do
endif
je = je - 1
endif
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)
end do
end do
endif
endif
end do !block loop
else ! regular global sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)
end do
end do
endif
endif
end do !block loop
endif
!call timer_stop(timer_local)
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_sum, global_sum_real, 1, &
mpi_real, MPI_SUM, dist%communicator, ierr)
else
global_sum_real = c0
endif
else
global_sum_real = local_sum
endif
else ! b4b
!-----------------------------------------------------------------------
!
! use this code for sums that are more reproducible - performance
! of this code does not scale well for large numbers of blocks
! NOTE: THIS CODE NOT MODIFIED FOR TRIPOLE GRIDS YET
!
!-----------------------------------------------------------------------
allocate (local_block_sum(nblocks_tot), &
global_block_sum(nblocks_tot))
local_block_sum = c0
if (present(MASK)) then
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)*MASK(i,j,bid)
end do
end do
endif
end do
else
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)
end do
end do
endif
end do
endif
call MPI_ALLREDUCE(local_block_sum, global_block_sum, nblocks_tot, &
mpi_real, MPI_SUM, dist%communicator, ierr)
global_sum_real = c0
do n=1,nblocks_tot
global_sum_real = global_sum_real + global_block_sum(n)
end do
deallocate ( local_block_sum, global_block_sum)
endif ! b4b
!-----------------------------------------------------------------------
end function global_sum_real
!***********************************************************************
function global_sum_int(X, dist, field_loc, MASK),7
!-----------------------------------------------------------------------
!
! computes the global sum of the _physical domain_ of a 2-d
! array.
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
!-----------------------------------------------------------------------
!
! input vars
!
!-----------------------------------------------------------------------
integer (int_kind), dimension(:,:,:), intent(in) :: &
X ! array to be summed
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
real (r8), dimension(size(X,dim=1), &
size(X,dim=2), &
size(X,dim=3)), intent(in), optional :: &
MASK ! real multiplicative mask
!-----------------------------------------------------------------------
!
! output result
!
!-----------------------------------------------------------------------
integer (int_kind) :: &
global_sum_int ! resulting global sum
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (int_kind), dimension(:), allocatable :: &
local_block_sum, &! sum of local blocks
global_block_sum ! sum of all blocks
integer (int_kind) :: &
local_sum ! sum of local blocks
integer (int_kind) :: &
i,j,n, &! local counters
ib,ie,jb,je, &! beg,end of physical domain
bid, &! block location
ierr ! MPI error flag
type (block) :: &
this_block ! holds local block information
if (.not. b4b) then
!-----------------------------------------------------------------------
!
! use this code for sums that are not reproducible but perform better
!
!-----------------------------------------------------------------------
local_sum = c0
!call timer_start(timer_local)
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
if (present(MASK)) then
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + X(i,je,bid)*MASK(i,je,bid)
end do
else ! no mask
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + X(i,je,bid)
end do
endif
je = je - 1
endif
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)
end do
end do
endif
endif
end do !block loop
else ! regular global sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)
end do
end do
endif
endif
end do !block loop
endif
!call timer_stop(timer_local)
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_sum, global_sum_int, 1, &
mpi_integer, MPI_SUM, dist%communicator, ierr)
else
global_sum_int = 0
endif
else
global_sum_int = local_sum
endif
else ! b4b
!-----------------------------------------------------------------------
!
! use this code for sums that are more reproducible - performance
! of this code does not scale well for large numbers of blocks
! NOTE: THIS CODE NOT YET CHANGED FOR TRIPOLE GRID
!
!-----------------------------------------------------------------------
allocate (local_block_sum(nblocks_tot), &
global_block_sum(nblocks_tot))
local_block_sum = c0
if (present(MASK)) then
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)*MASK(i,j,bid)
end do
end do
endif
end do
else
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)
end do
end do
endif
end do
endif
call MPI_ALLREDUCE(local_block_sum, global_block_sum, nblocks_tot, &
mpi_integer, MPI_SUM, dist%communicator, ierr)
global_sum_int = 0
do n=1,nblocks_tot
global_sum_int = global_sum_int + global_block_sum(n)
end do
deallocate ( local_block_sum, global_block_sum)
endif ! b4b
!-----------------------------------------------------------------------
end function global_sum_int
!***********************************************************************
function global_sum_scalar_dbl(local_scalar, dist),1
!-----------------------------------------------------------------------
!
! this function returns the sum of scalar value across processors
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
type (distrb), intent(in) :: &
dist ! distribution from which this is called
real (r8), intent(inout) :: &
local_scalar ! local scalar to be compared
real (r8) :: &
global_sum_scalar_dbl ! resulting global sum
integer (int_kind) :: ierr ! MPI error flag
!-----------------------------------------------------------------------
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_scalar, global_sum_scalar_dbl, 1, &
mpi_dbl, MPI_SUM, dist%communicator, ierr)
else
global_sum_scalar_dbl = c0
endif
else
global_sum_scalar_dbl = local_scalar
endif
!-----------------------------------------------------------------------
end function global_sum_scalar_dbl
!***********************************************************************
function global_sum_scalar_real(local_scalar, dist),1
!-----------------------------------------------------------------------
!
! this function returns the sum of scalar value across processors
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
real (r4), intent(inout) :: &
local_scalar ! local scalar to be compared
type (distrb), intent(in) :: &
dist ! distribution from which this is called
real (r4) :: &
global_sum_scalar_real ! resulting global sum
integer (int_kind) :: ierr ! MPI error flag
!-----------------------------------------------------------------------
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_scalar, global_sum_scalar_real, 1, &
MPI_REAL, MPI_SUM, dist%communicator, ierr)
else
global_sum_scalar_real = c0
endif
else
global_sum_scalar_real = local_scalar
endif
!-----------------------------------------------------------------------
end function global_sum_scalar_real
!***********************************************************************
function global_sum_scalar_int(local_scalar, dist),1
!-----------------------------------------------------------------------
!
! this function returns the sum of scalar value across processors
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
integer (int_kind), intent(inout) :: &
local_scalar ! local scalar to be compared
type (distrb), intent(in) :: &
dist ! distribution from which this is called
integer (int_kind) :: &
global_sum_scalar_int ! resulting global sum
integer (int_kind) :: ierr ! MPI error flag
!-----------------------------------------------------------------------
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_scalar, global_sum_scalar_int, 1, &
MPI_INTEGER, MPI_SUM, dist%communicator, ierr)
else
global_sum_scalar_int = 0
endif
else
global_sum_scalar_int = local_scalar
endif
!-----------------------------------------------------------------------
end function global_sum_scalar_int
!EOC
!***********************************************************************
!BOP
! !IROUTINE: global_sum_prod
! !INTERFACE:
function global_sum_prod_dbl (X,Y,dist,field_loc, MASK) 2,7
! !DESCRIPTION:
! this routine performs a global sum over the physical domain
! of a product of two 2-d arrays.
!
! !REVISION HISTORY:
! same as module
!
! !REMARKS:
! This is actually the specific interface for the generic
! global_sum_prod function corresponding to double precision arrays.
! The generic interface is identical but will handle real and integer
! 2-d slabs.
! !USES:
include 'mpif.h' ! MPI Fortran include file
! !INPUT PARAMETERS:
real (r8), dimension(:,:,:), intent(in) :: &
X, &! first array in product to be summed
Y ! second array in product to be summed
type (distrb), intent(in) :: &
dist ! block distribution for array X,Y
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
real (r8), &
dimension(size(X,dim=1),size(X,dim=2),size(X,dim=3)), &
intent(in), optional :: &
MASK ! real multiplicative mask
! !OUTPUT PARAMETERS:
real (r8) :: &
global_sum_prod_dbl ! resulting global sum of X*Y
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r8), dimension(:), allocatable :: &
local_block_sum, &! sum of each block
global_block_sum ! global sum each block
real (r8) :: &
local_sum ! sum of each block
integer (int_kind) :: &
i,j,n, &! dummy counters
bid, &! local block location
ib,ie,jb,je, &! beg,end indices of physical domain
ierr ! MPI error flag
type (block) :: &
this_block ! holds local block information
if (b4b) then
!-----------------------------------------------------------------------
!
! use this code for sums that are not reproducible but perform better
!
!-----------------------------------------------------------------------
local_sum = c0
!call timer_start(timer_local)
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
if (present(MASK)) then
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + &
X(i,je,bid)*Y(i,je,bid)*MASK(i,je,bid)
end do
else ! no mask
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + X(i,je,bid)*Y(i,je,bid)
end do
endif
je = je - 1
endif
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + &
X(i,j,bid)*Y(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*Y(i,j,bid)
end do
end do
endif
endif
end do !block loop
else ! regular global sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + &
X(i,j,bid)*Y(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*Y(i,j,bid)
end do
end do
endif
endif
end do !block loop
endif
!call timer_stop(timer_local)
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_sum, global_sum_prod_dbl, 1, &
mpi_dbl, MPI_SUM, dist%communicator, ierr)
else
global_sum_prod_dbl = 0
endif
else
global_sum_prod_dbl = local_sum
endif
else ! b4b
!-----------------------------------------------------------------------
!
! use this code for sums that are more reproducible - performance
! of this code does not scale well for large numbers of blocks
! NOTE: THIS CODE NOT YET CHANGED FOR TRIPOLE GRIDS
!
!-----------------------------------------------------------------------
allocate (local_block_sum(nblocks_tot), &
global_block_sum(nblocks_tot))
local_block_sum = c0
if (present(MASK)) then
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)*Y(i,j,bid)*MASK(i,j,bid)
end do
end do
endif
end do
else
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)*Y(i,j,bid)
end do
end do
endif
end do
endif
call MPI_ALLREDUCE(local_block_sum, global_block_sum, nblocks_tot, &
mpi_dbl, MPI_SUM, dist%communicator, ierr)
global_sum_prod_dbl = c0
do n=1,nblocks_tot
global_sum_prod_dbl = global_sum_prod_dbl + global_block_sum(n)
end do
deallocate ( local_block_sum, global_block_sum)
endif ! b4b
!-----------------------------------------------------------------------
end function global_sum_prod_dbl
!***********************************************************************
function global_sum_prod_real (X, Y, dist, field_loc, MASK),7
!-----------------------------------------------------------------------
!
! this routine performs a global sum over the physical domain
! of a product of two 2-d arrays.
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
!-----------------------------------------------------------------------
!
! input variables
!
!-----------------------------------------------------------------------
real (r4), dimension(:,:,:), intent(in) :: &
X, &! first array in product to be summed
Y ! second array in product to be summed
type (distrb), intent(in) :: &
dist ! block distribution for array X,Y
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
real (r8), &
dimension(size(X,dim=1),size(X,dim=2),size(X,dim=3)), &
intent(in), optional :: &
MASK ! real multiplicative mask
!-----------------------------------------------------------------------
!
! output variables
!
!-----------------------------------------------------------------------
real (r4) :: &
global_sum_prod_real ! resulting global sum of X*Y
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r8), dimension(:), allocatable :: &
local_block_sum, &! sum of each block
global_block_sum ! global sum each block
real (r8) :: &
local_sum, &! sum of local blocks
global_sum_prod_tmp ! sum of global blocks
integer (int_kind) :: &
i,j,n, &! dummy counters
bid, &! local block location
ib,ie,jb,je, &! beg,end indices of physical domain
ierr ! MPI error flag
type (block) :: &
this_block ! holds local block information
if (b4b) then
!-----------------------------------------------------------------------
!
! use this code for sums that are not reproducible but perform better
!
!-----------------------------------------------------------------------
local_sum = c0
!call timer_start(timer_local)
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
if (present(MASK)) then
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + &
X(i,je,bid)*Y(i,je,bid)*MASK(i,je,bid)
end do
else ! no mask
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + X(i,je,bid)*Y(i,je,bid)
end do
endif
je = je - 1
endif
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + &
X(i,j,bid)*Y(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*Y(i,j,bid)
end do
end do
endif
endif
end do !block loop
else ! regular global sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + &
X(i,j,bid)*Y(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*Y(i,j,bid)
end do
end do
endif
endif
end do !block loop
endif
!call timer_stop(timer_local)
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_sum, global_sum_prod_tmp, 1, &
mpi_dbl, MPI_SUM, dist%communicator, ierr)
global_sum_prod_real = global_sum_prod_tmp
else
global_sum_prod_real = 0
endif
else
global_sum_prod_real = local_sum
endif
else ! b4b
!-----------------------------------------------------------------------
!
! use this code for sums that are more reproducible - performance
! of this code does not scale well for large numbers of blocks
! NOTE: THIS CODE NOT YET CHANGED FOR TRIPOLE GRIDS
!
!-----------------------------------------------------------------------
allocate (local_block_sum(nblocks_tot), &
global_block_sum(nblocks_tot))
local_block_sum = c0
if (present(MASK)) then
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)*Y(i,j,bid)*MASK(i,j,bid)
end do
end do
endif
end do
else
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)*Y(i,j,bid)
end do
end do
endif
end do
endif
call MPI_ALLREDUCE(local_block_sum, global_block_sum, nblocks_tot, &
mpi_dbl, MPI_SUM, dist%communicator, ierr)
global_sum_prod_real = c0
do n=1,nblocks_tot
global_sum_prod_real = global_sum_prod_real + global_block_sum(n)
end do
deallocate ( local_block_sum, global_block_sum)
endif ! b4b
!-----------------------------------------------------------------------
end function global_sum_prod_real
!***********************************************************************
function global_sum_prod_int (X, Y, dist, field_loc, MASK),7
!-----------------------------------------------------------------------
!
! this routine performs a global sum over the physical domain
! of a product of two 2-d arrays.
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
!-----------------------------------------------------------------------
!
! input variables
!
!-----------------------------------------------------------------------
integer (int_kind), dimension(:,:,:), intent(in) :: &
X, &! first array in product to be summed
Y ! second array in product to be summed
type (distrb), intent(in) :: &
dist ! block distribution for array X,Y
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
real (r8), &
dimension(size(X,dim=1),size(X,dim=2),size(X,dim=3)), &
intent(in), optional :: &
MASK ! real multiplicative mask
!-----------------------------------------------------------------------
!
! output variables
!
!-----------------------------------------------------------------------
integer (int_kind) :: &
global_sum_prod_int ! resulting global sum of X*Y
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (int_kind), dimension(:), allocatable :: &
local_block_sum, &! sum of each block
global_block_sum ! global sum each block
integer (int_kind) :: &
local_sum ! sum of local blocks
integer (int_kind) :: &
i,j,n, &! dummy counters
bid, &! local block location
ib,ie,jb,je, &! beg,end indices of physical domain
ierr ! MPI error flag
type (block) :: &
this_block ! holds local block information
if (b4b) then
!-----------------------------------------------------------------------
!
! use this code for sums that are not reproducible but perform better
!
!-----------------------------------------------------------------------
local_sum = c0
!call timer_start(timer_local)
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
if (present(MASK)) then
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + &
X(i,je,bid)*Y(i,je,bid)*MASK(i,je,bid)
end do
else ! no mask
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2) &
local_sum = local_sum + X(i,je,bid)*Y(i,je,bid)
end do
endif
je = je - 1
endif
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + &
X(i,j,bid)*Y(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*Y(i,j,bid)
end do
end do
endif
endif
end do !block loop
else ! regular global sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(MASK)) then
do j=jb,je
do i=ib,ie
local_sum = local_sum + &
X(i,j,bid)*Y(i,j,bid)*MASK(i,j,bid)
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_sum = local_sum + X(i,j,bid)*Y(i,j,bid)
end do
end do
endif
endif
end do !block loop
endif
!call timer_stop(timer_local)
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_sum, global_sum_prod_int, 1, &
mpi_integer, MPI_SUM, dist%communicator, ierr)
else
global_sum_prod_int = 0
endif
else
global_sum_prod_int = local_sum
endif
else ! b4b
!-----------------------------------------------------------------------
!
! use this code for sums that are more reproducible - performance
! of this code does not scale well for large numbers of blocks
! NOTE: THIS CODE NOT YET CHANGED FOR TRIPOLE GRIDS
!
!-----------------------------------------------------------------------
allocate (local_block_sum(nblocks_tot), &
global_block_sum(nblocks_tot))
local_block_sum = c0
if (present(MASK)) then
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)*Y(i,j,bid)*MASK(i,j,bid)
end do
end do
endif
end do
else
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
do j=jb,je
do i=ib,ie
local_block_sum(n) = &
local_block_sum(n) + X(i,j,bid)*Y(i,j,bid)
end do
end do
endif
end do
endif
call MPI_ALLREDUCE(local_block_sum, global_block_sum, nblocks_tot, &
mpi_integer, MPI_SUM, dist%communicator, ierr)
global_sum_prod_int = 0
do n=1,nblocks_tot
global_sum_prod_int = global_sum_prod_int + global_block_sum(n)
end do
deallocate ( local_block_sum, global_block_sum)
endif ! b4b
!-----------------------------------------------------------------------
end function global_sum_prod_int
!EOC
!***********************************************************************
!BOP
! !IROUTINE: global_count
! !INTERFACE:
function global_count_dbl (MASK, dist, field_loc) 1,2
! !DESCRIPTION:
! This function returns the number of true or non-zero elements
! in the physical domain of a 2-d array.
!
! !REVISION HISTORY:
! same as module
!
! !REMARKS:
! This is actually the specific interface for the generic
! global_count function corresponding to double precision arrays.
! The generic interface is identical but will handle real and integer
! and logical arrays.
! !USES:
include 'mpif.h' ! MPI Fortran include file
!INPUT PARAMETERS:
real (r8), dimension(:,:,:), intent(in) :: &
MASK
type (distrb), intent(in) :: &
dist ! block distribution for MASK
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
!OUTPUT PARAMETERS:
integer (int_kind) :: &
global_count_dbl ! resulting global count
!EOP
!BOC
integer (int_kind) :: &
local_count, &! local count of subdomain
ierr, &! MPI error flag
ib, ie, jb, je, &! start,end of physical domain
bid, &! block location in distribution
i, n ! dummy counters
type (block) :: &
this_block ! holds local block information
!-----------------------------------------------------------------------
local_count = 0
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2 .and. &
MASK(i,je,bid) /= c0) &
local_count = local_count + 1
end do
je = je - 1
endif
local_count = local_count &
+ count(MASK(ib:ie,jb:je,bid) /= c0)
endif
end do !block loop
else ! regular global count
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
local_count = local_count &
+ count(MASK(ib:ie,jb:je,bid) /= c0)
endif
end do !block loop
endif
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_count, global_count_dbl, 1, &
MPI_INTEGER, MPI_SUM, dist%communicator, ierr)
else
global_count_dbl = 0
endif
else
global_count_dbl = local_count
endif
!-----------------------------------------------------------------------
end function global_count_dbl
!***********************************************************************
function global_count_real (MASK, dist, field_loc),2
!-----------------------------------------------------------------------
!
! this function returns the number of true or non-zero elements
! in the physical domain of a 2-d array
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
real (r4), dimension(:,:,:), intent(in) :: &
MASK
type (distrb), intent(in) :: &
dist ! block distribution for MASK
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
integer (int_kind) :: &
global_count_real, &! resulting global count
local_count, &! local count of subdomain
ierr, &! MPI error flag
ib, ie, jb, je, &! start,end of physical domain
bid, &! block location in distribution
i, n ! dummy counters
type (block) :: &
this_block ! holds local block information
!-----------------------------------------------------------------------
local_count = 0
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2 .and. &
MASK(i,je,bid) /= c0) &
local_count = local_count + 1
end do
je = je - 1
endif
local_count = local_count &
+ count(MASK(ib:ie,jb:je,bid) /= c0)
endif
end do !block loop
else ! regular global count
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
local_count = local_count &
+ count(MASK(ib:ie,jb:je,bid) /= c0)
endif
end do !block loop
endif
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_count, global_count_real, 1, &
MPI_INTEGER, MPI_SUM, dist%communicator, ierr)
else
global_count_real = 0
endif
else
global_count_real = local_count
endif
!-----------------------------------------------------------------------
end function global_count_real
!***********************************************************************
function global_count_int (MASK, dist, field_loc),2
!-----------------------------------------------------------------------
!
! this function returns the number of true or non-zero elements
! in the physical domain of a 2-d array
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
integer (int_kind), dimension(:,:,:), intent(in) :: &
MASK
type (distrb), intent(in) :: &
dist ! block distribution for MASK
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
integer (int_kind) :: &
global_count_int, &! resulting global count
local_count, &! local count of subdomain
ierr, &! MPI error flag
ib, ie, jb, je, &! start,end of physical domain
bid, &! block location in distribution
i, n ! dummy counters
type (block) :: &
this_block ! holds local block information
!-----------------------------------------------------------------------
local_count = 0
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2 .and. &
MASK(i,je,bid) /= 0) &
local_count = local_count + 1
end do
je = je - 1
endif
local_count = local_count &
+ count(MASK(ib:ie,jb:je,bid) /= 0)
endif
end do !block loop
else ! regular global count
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
local_count = local_count &
+ count(MASK(ib:ie,jb:je,bid) /= 0)
endif
end do !block loop
endif
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_count, global_count_int, 1, &
MPI_INTEGER, MPI_SUM, dist%communicator, ierr)
else
global_count_int = 0
endif
else
global_count_int = local_count
endif
!-----------------------------------------------------------------------
end function global_count_int
!***********************************************************************
function global_count_log (MASK, dist, field_loc),2
!-----------------------------------------------------------------------
!
! this function returns the number of true or non-zero elements
! in the physical domain of a 2-d array
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
logical (log_kind), dimension(:,:,:), intent(in) :: &
MASK
type (distrb), intent(in) :: &
dist ! block distribution for MASK
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
integer (int_kind) :: &
global_count_log ! resulting global count
integer (int_kind) :: &
local_count, &! local count of subdomain
ierr, &! MPI error flag
ib, ie, jb, je, &! start,end of physical domain
bid, &! block location in distribution
i, n ! dummy counters
type (block) :: &
this_block ! holds local block information
!-----------------------------------------------------------------------
local_count = 0
if (ltripole_grid .and. (field_loc == field_loc_Nface .or. &
field_loc == field_loc_NEcorner)) then
!*** must remove redundant points from sum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
ib = this_block%ib
ie = this_block%ie
jb = this_block%jb
je = this_block%je
if (this_block%jblock == nblocks_y) then
!*** for topmost row in tripole only sum
!*** 1st half of domain - others are redundant
do i=ib,ie
if (this_block%i_glob(i) <= nx_global/2 .and. &
MASK(i,je,bid)) &
local_count = local_count + 1
end do
je = je - 1
endif
local_count = local_count &
+ count(MASK(ib:ie,jb:je,bid))
endif
end do !block loop
else ! regular global count
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
local_count = local_count &
+ count(MASK(ib:ie,jb:je,bid))
endif
end do !block loop
endif
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_count, global_count_log, 1, &
MPI_INTEGER, MPI_SUM, dist%communicator, ierr)
else
global_count_log = 0
endif
else
global_count_log = local_count
endif
!-----------------------------------------------------------------------
!EOC
end function global_count_log
!***********************************************************************
!BOP
! !IROUTINE: global_maxval
! !INTERFACE:
function global_maxval_dbl (X, dist, field_loc, LMASK) 2,4
! !DESCRIPTION:
! This function computes the global maxval of the physical domain
! of a 2-d field
!
! !REVISION HISTORY:
! same as module
!
! !REMARKS:
! This is actually the specific interface for the generic global_maxval
! function corresponding to double precision arrays. The generic
! interface is identical but will handle real and integer 2-d slabs.
! !USES:
include 'mpif.h' ! MPI Fortran include file
!EOP
!BOC
!-----------------------------------------------------------------------
!
! input vars
!
!-----------------------------------------------------------------------
real (r8), dimension(:,:,:), intent(in) :: &
X ! array containing field for which max required
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
logical (log_kind), &
dimension(size(X,dim=1),size(X,dim=2),size(X,dim=3)), &
intent(in), optional :: &
LMASK ! mask for excluding parts of domain
!-----------------------------------------------------------------------
!
! output result
!
!-----------------------------------------------------------------------
real (r8) :: &
global_maxval_dbl ! resulting max val of global domain
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r8) :: &
local_maxval ! max value of local subdomain
integer (int_kind) :: &
i,j,n,bid, &
ib, ie, jb, je, &! start,end of physical domain
ierr ! MPI error flag
!-----------------------------------------------------------------------
local_maxval = -bignum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(LMASK)) then
do j=jb,je
do i=ib,ie
if (LMASK(i,j,bid)) &
local_maxval = max(local_maxval,X(i,j,bid))
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_maxval = max(local_maxval,X(i,j,bid))
end do
end do
endif
endif
end do ! block loop
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_maxval, global_maxval_dbl, 1, &
mpi_dbl, MPI_MAX, dist%communicator, ierr)
else
global_maxval_dbl = c0
endif
else
global_maxval_dbl = local_maxval
endif
!-----------------------------------------------------------------------
end function global_maxval_dbl
!***********************************************************************
function global_maxval_real (X, dist, field_loc, LMASK),4
!-----------------------------------------------------------------------
!
! this function computes the global maxval of the physical domain
! of a 2-d field
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
!-----------------------------------------------------------------------
!
! input vars
!
!-----------------------------------------------------------------------
real (r4), dimension(:,:,:), intent(in) :: &
X ! array containing field for which max required
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
logical (log_kind), &
dimension(size(X,dim=1),size(X,dim=2),size(X,dim=3)), &
intent(in), optional :: &
LMASK ! mask for excluding parts of domain
!-----------------------------------------------------------------------
!
! output result
!
!-----------------------------------------------------------------------
real (r4) :: &
global_maxval_real ! resulting max val of global domain
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r4) :: &
local_maxval ! max value of local subdomain
integer (int_kind) :: &
i,j,n,bid, &
ib, ie, jb, je, &! start,end of physical domain
ierr ! MPI error flag
!-----------------------------------------------------------------------
local_maxval = -bignum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(LMASK)) then
do j=jb,je
do i=ib,ie
if (LMASK(i,j,bid)) &
local_maxval = max(local_maxval,X(i,j,bid))
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_maxval = max(local_maxval,X(i,j,bid))
end do
end do
endif
endif
end do ! block loop
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_maxval, global_maxval_real, 1, &
mpi_real, MPI_MAX, dist%communicator, ierr)
else
global_maxval_real = c0
endif
else
global_maxval_real = local_maxval
endif
!-----------------------------------------------------------------------
end function global_maxval_real
!***********************************************************************
function global_maxval_int (X, dist, field_loc, LMASK),4
!-----------------------------------------------------------------------
!
! this function computes the global maxval of the physical domain
! of a 2-d field
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
!-----------------------------------------------------------------------
!
! input vars
!
!-----------------------------------------------------------------------
integer (int_kind), dimension(:,:,:), intent(in) :: &
X ! array containing field for which max required
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
logical (log_kind), &
dimension(size(X,dim=1),size(X,dim=2),size(X,dim=3)), &
intent(in), optional :: &
LMASK ! mask for excluding parts of domain
!-----------------------------------------------------------------------
!
! output result
!
!-----------------------------------------------------------------------
integer (int_kind) :: &
global_maxval_int ! resulting max val of global domain
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (int_kind) :: &
local_maxval ! max value of local subdomain
integer (int_kind) :: &
i,j,n,bid, &
ib, ie, jb, je, &! start,end of physical domain
ierr ! MPI error flag
!-----------------------------------------------------------------------
local_maxval = -1000000
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(LMASK)) then
do j=jb,je
do i=ib,ie
if (LMASK(i,j,bid)) &
local_maxval = max(local_maxval,X(i,j,bid))
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_maxval = max(local_maxval,X(i,j,bid))
end do
end do
endif
endif
end do ! block loop
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_maxval, global_maxval_int, 1, &
mpi_integer, MPI_MAX, dist%communicator, ierr)
else
global_maxval_int = 0
endif
else
global_maxval_int = local_maxval
endif
!-----------------------------------------------------------------------
!EOC
end function global_maxval_int
!***********************************************************************
!BOP
! !IROUTINE: global_minval
! !INTERFACE:
function global_minval_dbl (X, dist, field_loc, LMASK) 2,4
! !DESCRIPTION:
! This function computes the global minval of the physical domain
! of a 2-d field
!
! !REVISION HISTORY:
! same as module
!
! !REMARKS:
! This is actually the specific interface for the generic global_minval
! function corresponding to double precision arrays. The generic
! interface is identical but will handle real and integer 2-d slabs.
! !USES:
include 'mpif.h' ! MPI Fortran include file
! !INPUT PARAMETERS:
real (r8), dimension(:,:,:), intent(in) :: &
X ! array containing field for which min required
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
logical (log_kind), &
dimension(size(X,dim=1),size(X,dim=2),size(X,dim=3)), &
intent(in), optional :: &
LMASK ! mask for excluding parts of domain
! !OUTPUT PARAMETERS:
real (r8) :: &
global_minval_dbl ! resulting min val of global domain
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r8) :: &
local_minval ! min value of local subdomain
integer (int_kind) :: &
i,j,n,bid, &
ib, ie, jb, je, &! start,end of physical domain
ierr ! MPI error flag
!-----------------------------------------------------------------------
local_minval = bignum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(LMASK)) then
do j=jb,je
do i=ib,ie
if (LMASK(i,j,bid)) &
local_minval = min(local_minval,X(i,j,bid))
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_minval = min(local_minval,X(i,j,bid))
end do
end do
endif
endif
end do
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_minval, global_minval_dbl, 1, &
mpi_dbl, MPI_MIN, dist%communicator, ierr)
else
global_minval_dbl = c0
endif
else
global_minval_dbl = local_minval
endif
!-----------------------------------------------------------------------
end function global_minval_dbl
!***********************************************************************
function global_minval_real (X, dist, field_loc, LMASK),4
!-----------------------------------------------------------------------
!
! this function computes the global minval of the physical domain
! of a 2-d field
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
!-----------------------------------------------------------------------
!
! input vars
!
!-----------------------------------------------------------------------
real (r4), dimension(:,:,:), intent(in) :: &
X ! array containing field for which min required
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
logical (log_kind), &
dimension(size(X,dim=1),size(X,dim=2),size(X,dim=3)), &
intent(in), optional :: &
LMASK ! mask for excluding parts of domain
!-----------------------------------------------------------------------
!
! output result
!
!-----------------------------------------------------------------------
real (r4) :: &
global_minval_real ! resulting min val of global domain
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r4) :: &
local_minval ! min value of local subdomain
integer (int_kind) :: &
i,j,n,bid, &
ib, ie, jb, je, &! start,end of physical domain
ierr ! MPI error flag
!-----------------------------------------------------------------------
local_minval = bignum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(LMASK)) then
do j=jb,je
do i=ib,ie
if (LMASK(i,j,bid)) &
local_minval = min(local_minval,X(i,j,bid))
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_minval = min(local_minval,X(i,j,bid))
end do
end do
endif
endif
end do ! block loop
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_minval, global_minval_real, 1, &
mpi_real, MPI_MIN, dist%communicator, ierr)
else
global_minval_real = c0
endif
else
global_minval_real = local_minval
endif
!-----------------------------------------------------------------------
end function global_minval_real
!***********************************************************************
function global_minval_int (X, dist, field_loc, LMASK),4
!-----------------------------------------------------------------------
!
! this function computes the global minval of the physical domain
! of a 2-d field
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
!-----------------------------------------------------------------------
!
! input vars
!
!-----------------------------------------------------------------------
integer (int_kind), dimension(:,:,:), intent(in) :: &
X ! array containing field for which min required
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
logical (log_kind), &
dimension(size(X,dim=1),size(X,dim=2),size(X,dim=3)), &
intent(in), optional :: &
LMASK ! mask for excluding parts of domain
!-----------------------------------------------------------------------
!
! output result
!
!-----------------------------------------------------------------------
integer (int_kind) :: &
global_minval_int ! resulting min val of global domain
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (int_kind) :: &
local_minval ! min value of local subdomain
integer (int_kind) :: &
i,j,n,bid, &
ib, ie, jb, je, &! start,end of physical domain
ierr ! MPI error flag
!-----------------------------------------------------------------------
local_minval = 1000000
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
call get_block_parameter(n,ib=ib,ie=ie,jb=jb,je=je)
if (present(LMASK)) then
do j=jb,je
do i=ib,ie
if (LMASK(i,j,bid)) &
local_minval = min(local_minval,X(i,j,bid))
end do
end do
else ! no mask
do j=jb,je
do i=ib,ie
local_minval = min(local_minval,X(i,j,bid))
end do
end do
endif
endif
end do
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLREDUCE(local_minval, global_minval_int, 1, &
mpi_integer, MPI_MIN, dist%communicator, ierr)
else
global_minval_int = 0
endif
else
global_minval_int = local_minval
endif
!-----------------------------------------------------------------------
end function global_minval_int
!***********************************************************************
function global_maxval_scalar_dbl (local_scalar),1
!-----------------------------------------------------------------------
!
! this function returns the maximum scalar value across processors
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
real (r8), intent(inout) :: &
local_scalar ! local scalar to be compared
real (r8) :: &
global_maxval_scalar_dbl ! resulting global max
integer (int_kind) :: ierr ! MPI error flag
!-----------------------------------------------------------------------
call MPI_ALLREDUCE(local_scalar, global_maxval_scalar_dbl, 1, &
mpi_dbl, MPI_MAX, MPI_COMM_OCN, ierr)
!-----------------------------------------------------------------------
end function global_maxval_scalar_dbl
!***********************************************************************
function global_maxval_scalar_real (local_scalar),1
!-----------------------------------------------------------------------
!
! this function returns the maximum scalar value across processors
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
real (r4), intent(inout) :: &
local_scalar ! local scalar to be compared
real (r4) :: &
global_maxval_scalar_real ! resulting global max
integer (int_kind) :: ierr ! MPI error flag
!-----------------------------------------------------------------------
call MPI_ALLREDUCE(local_scalar, global_maxval_scalar_real, 1, &
MPI_REAL, MPI_MAX, MPI_COMM_OCN, ierr)
!-----------------------------------------------------------------------
end function global_maxval_scalar_real
!***********************************************************************
function global_maxval_scalar_int (local_scalar),1
!-----------------------------------------------------------------------
!
! this function returns the maximum scalar value across processors
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
integer (int_kind), intent(inout) :: &
local_scalar ! local scalar to be compared
integer (int_kind) :: &
global_maxval_scalar_int ! resulting global max
integer (int_kind) :: ierr ! MPI error flag
!-----------------------------------------------------------------------
call MPI_ALLREDUCE(local_scalar, global_maxval_scalar_int, 1, &
MPI_INTEGER, MPI_MAX, MPI_COMM_OCN, ierr)
!-----------------------------------------------------------------------
end function global_maxval_scalar_int
!***********************************************************************
function global_minval_scalar_dbl (local_scalar),1
!-----------------------------------------------------------------------
!
! this function returns the minimum scalar value across processors
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
real (r8), intent(inout) :: &
local_scalar ! local scalar to be compared
real (r8) :: &
global_minval_scalar_dbl ! resulting global min
integer (int_kind) :: ierr ! MPI error flag
!-----------------------------------------------------------------------
call MPI_ALLREDUCE(local_scalar, global_minval_scalar_dbl, 1, &
mpi_dbl, MPI_MIN, MPI_COMM_OCN, ierr)
!-----------------------------------------------------------------------
end function global_minval_scalar_dbl
!***********************************************************************
function global_minval_scalar_real (local_scalar),1
!-----------------------------------------------------------------------
!
! this function returns the minimum scalar value across processors
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
real (r4), intent(inout) :: &
local_scalar ! local scalar to be compared
real (r4) :: &
global_minval_scalar_real ! resulting global min
integer (int_kind) :: ierr ! MPI error flag
!-----------------------------------------------------------------------
call MPI_ALLREDUCE(local_scalar, global_minval_scalar_real, 1, &
MPI_REAL, MPI_MIN, MPI_COMM_OCN, ierr)
!-----------------------------------------------------------------------
end function global_minval_scalar_real
!***********************************************************************
function global_minval_scalar_int (local_scalar),1
!-----------------------------------------------------------------------
!
! this function returns the minimum scalar value across processors
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
integer (int_kind), intent(inout) :: &
local_scalar ! local scalar to be compared
integer (int_kind) :: &
global_minval_scalar_int ! resulting global min
integer (int_kind) :: ierr ! MPI error flag
!-----------------------------------------------------------------------
call MPI_ALLREDUCE(local_scalar, global_minval_scalar_int, 1, &
MPI_INTEGER, MPI_MIN, MPI_COMM_OCN, ierr)
!-----------------------------------------------------------------------
!EOC
end function global_minval_scalar_int
!***********************************************************************
!BOP
! !IROUTINE: global_maxloc
! !INTERFACE:
subroutine global_maxloc_dbl(WORK,dist,field_loc,ival,jval,val) 1,1
! !DESCRIPTION:
! This routine finds the location of the global maximum for the
! physical domain of a 2-d field
!
! !REVISION HISTORY:
! same as module
!
! !REMARKS:
! This is actually the specific interface for the generic global_maxval
! function corresponding to double precision arrays. The generic
! interface is identical but will handle real and integer 2-d slabs.
! !USES:
include 'mpif.h' ! MPI Fortran include file
! !INPUT PARAMETERS:
real (r8), dimension(:,:,:), intent(in) :: &
WORK ! array for which maxloc required
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
! !OUTPUT PARAMETERS:
real (r8), intent(out) :: &
val ! maximum value of the field
integer (int_kind), intent(out) :: &
ival, jval ! global i,j location of maximum
!EOP
!BOC
integer (int_kind) :: &
i, j, n, bid, &! dummy counters
ierr ! MPI error flag
real (r8), dimension(3) :: &
local_val ! local array to hold local i,j,val
real (r8), dimension(:), allocatable :: &
global_val ! array to hold gathered i,j,val from others
type (block) :: &
this_block ! current block info
!-----------------------------------------------------------------------
!***
!*** find local maxval with global location
!***
val = -bignum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
if (WORK(i,j,bid) > val) then
val = WORK(i,j,bid)
local_val(1) = val
local_val(2) = this_block%i_glob(i)
local_val(3) = this_block%j_glob(j)
endif
end do
end do
endif
end do
!***
!*** gather all similar results from other processors
!***
allocate (global_val(0:(3*dist%nprocs)-1))
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLGATHER(local_val , 3, mpi_dbl, &
global_val, 3, mpi_dbl, &
dist%communicator, ierr)
else
global_val = c0
endif
else
global_val(0:2) = local_val(1:3)
endif
!***
!*** find max and location by comparing the gathered results
!***
val = -bignum
ival = 0
jval = 0
do n=0,3*dist%nprocs-1,3
if (global_val(n) > val) then
val = global_val(n )
ival = global_val(n+1)
jval = global_val(n+2)
end if
end do
deallocate(global_val)
!-----------------------------------------------------------------------
end subroutine global_maxloc_dbl
!***********************************************************************
subroutine global_maxloc_real(WORK,dist,field_loc,ival,jval,val),1
!-----------------------------------------------------------------------
!
! this routine finds the location of the global maximum for the
! physical domain of a 2-d field
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
real (r4), dimension(:,:,:), intent(in) :: &
WORK ! array for which maxloc required
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
real (r4), intent(out) :: &
val ! maximum value of the field
integer (int_kind), intent(out) :: &
ival, jval ! i,j location of maximum
integer (int_kind) :: &
i, j, n, bid, &! dummy counters
ierr ! MPI error flag
real (r4), dimension(3) :: &
local_val ! local array to hold local i,j,val
real (r4), dimension(:), allocatable :: &
global_val ! array to hold gathered i,j,val from others
type (block) :: &
this_block ! current block info
!-----------------------------------------------------------------------
!***
!*** find local maxval with global location
!***
val = -bignum
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
if (WORK(i,j,bid) > val) then
val = WORK(i,j,bid)
local_val(1) = val
local_val(2) = this_block%i_glob(i)
local_val(3) = this_block%j_glob(j)
endif
end do
end do
endif
end do
!***
!*** gather all similar results from other processors
!***
allocate (global_val(0:(3*dist%nprocs)-1))
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLGATHER(local_val , 3, mpi_real, &
global_val, 3, mpi_real, &
dist%communicator, ierr)
else
global_val = c0
endif
else
global_val(0:2) = local_val(1:3)
endif
!***
!*** find max and location by comparing the gathered results
!***
val = -bignum
ival = 0
jval = 0
do n=0,3*dist%nprocs-1,3
if (global_val(n) > val) then
val = global_val(n )
ival = global_val(n+1)
jval = global_val(n+2)
end if
end do
deallocate(global_val)
!-----------------------------------------------------------------------
end subroutine global_maxloc_real
!***********************************************************************
subroutine global_maxloc_int(WORK,dist,field_loc,ival,jval,val),1
!-----------------------------------------------------------------------
!
! this routine finds the location of the global maximum for the
! physical domain of a 2-d field
!
!-----------------------------------------------------------------------
include 'mpif.h' ! MPI Fortran include file
integer (int_kind), dimension(:,:,:), intent(in) :: &
WORK ! array for which maxloc required
type (distrb), intent(in) :: &
dist ! block distribution for array X
integer (int_kind), intent(in) :: &
field_loc ! location of field on staggered grid
integer (int_kind), intent(out) :: &
val ! maximum value of the field
integer (int_kind), intent(out) :: &
ival, jval ! i,j location of maximum
integer (int_kind) :: &
i, j, n, bid, &! dummy counters
ierr ! MPI error flag
integer (int_kind), dimension(3) :: &
local_val ! local array to hold local i,j,val
integer (int_kind), dimension(:), allocatable :: &
global_val ! array to hold gathered i,j,val from others
type (block) :: &
this_block ! current block info
!-----------------------------------------------------------------------
!***
!*** find local maxval with global location
!***
val = -1000000
do n=1,nblocks_tot
if (dist%proc(n) == my_task+1) then
bid = dist%local_block(n)
this_block = get_block(n,bid)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
if (WORK(i,j,bid) > val) then
val = WORK(i,j,bid)
local_val(1) = val
local_val(2) = this_block%i_glob(i)
local_val(3) = this_block%j_glob(j)
endif
end do
end do
endif
end do
!***
!*** gather all similar results from other processors
!***
allocate (global_val(0:(3*dist%nprocs)-1))
if (dist%nprocs > 1) then
if (my_task < dist%nprocs) then
call MPI_ALLGATHER(local_val , 3, mpi_integer, &
global_val, 3, mpi_integer, &
dist%communicator, ierr)
else
global_val = c0
endif
else
global_val(0:2) = local_val(1:3)
endif
!***
!*** find max and location by comparing the gathered results
!***
val = -1000000
ival = 0
jval = 0
do n=0,3*dist%nprocs-1,3
if (global_val(n) > val) then
val = global_val(n )
ival = global_val(n+1)
jval = global_val(n+2)
end if
end do
deallocate(global_val)
!-----------------------------------------------------------------------
!EOC
end subroutine global_maxloc_int
!***********************************************************************
end module global_reductions
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||