DISPATCH
mpi_global_mod.f90
1 !===============================================================================
2 !> Simple MPI global array data type
3 !===============================================================================
5  USE mpi_mod
6  USE trace_mod
7  implicit none
8  private
9  include "mpif.h"
10  type, public:: mpi_global_t
11  integer:: window=0
12  real(8), pointer:: a(:)
13  integer:: n=0
14  contains
15  procedure:: init
16  procedure, private:: update4
17  procedure, private:: update8
18  generic:: update => update4, update8
19  end type
20 CONTAINS
21 
22 !===============================================================================
23 !> Create and initialize a global double precision array(n).
24 !> NOTE: This is a COLLECTIVE call!
25 !===============================================================================
26 SUBROUTINE init (self, n)
27  class(mpi_global_t):: self
28  integer:: n
29  !.............................................................................
30  integer(kind=MPI_ADDRESS_KIND):: nbytes
31  integer:: mpi_err
32  !----------------------------------------------------------------------------
33  call trace%begin('mpi_global_t%init8')
34  !$omp critical (mpi_global_cr)
35  if (self%window==0) then
36  self%n = n
37  allocate (self%a(n))
38  nbytes = 8*n
39  self%a = 0d0
40 #ifdef __GFORTRAN__
41  self%window = -1
42 #else
43  call mpi_win_create (self%a, nbytes, 8, mpi_info_null, mpi_comm_world, &
44  self%window, mpi_err)
45  call mpi%assert ('MPI_Win_create', mpi_err)
46 #endif
47  end if
48  !$omp end critical (mpi_global_cr)
49  call trace%end
50 END SUBROUTINE init
51 
52 !===============================================================================
53 !> Add a value a(:) to the counter on master.
54 !===============================================================================
55 FUNCTION update4 (self, a) RESULT (b)
56  class(mpi_global_t):: self
57  real:: a(self%n), b(self%n)
58  !.............................................................................
59  b= update8(self, real(a,kind=8))
60 END FUNCTION update4
61 !===============================================================================
62 FUNCTION update8 (self, a) RESULT (b)
63  class(mpi_global_t):: self
64  real(8):: a(self%n), b(self%n)
65  integer:: i
66  !.............................................................................
67 #ifdef __GFORTRAN__
68  do i=1,3
69  !$omp atomic update
70  self%a(i) = self%a(i) + a(i)
71  end do
72  b = self%a
73 #else
74  if (mpi%size == 1) then
75  do i=1,3
76  !$omp atomic update
77  self%a(i) = self%a(i) + a(i)
78  end do
79  b = self%a
80  else
81  b = update8_real(self, a)
82  end if
83 #endif
84 END FUNCTION update8
85 !===============================================================================
86 FUNCTION update8_real (self, a) RESULT (b)
87  class(mpi_global_t):: self
88  real(8):: a(self%n), b(self%n)
89  !.............................................................................
90  integer:: master=0, mpi_err
91  integer(kind=MPI_ADDRESS_KIND):: offset=0
92  !-----------------------------------------------------------------------------
93  call trace%begin('mpi_global_t%init')
94  !$omp critical (mpi_global_cr)
95  call mpi_win_lock (mpi_lock_exclusive, master, 0, self%window, mpi_err)
96  call mpi_get_accumulate (a, self%n, mpi_real8, &
97  self%a, self%n, mpi_real8, master, offset, &
98  self%n, mpi_real8, mpi_sum, self%window, mpi_err)
99  call mpi%assert ('MPI_Accumulate', mpi_err)
100  call mpi_win_flush (master, self%window, mpi_err)
101  if (mpi%rank == master) then
102  b = self%a
103  else
104  b = self%a + a
105  end if
106  call mpi_win_unlock (master, self%window, mpi_err)
107  !$omp end critical (mpi_global_cr)
108  call trace%end
109 END FUNCTION update8_real
110 
111 END MODULE mpi_global_mod
Simple MPI global array data type.