Line data Source code
1 : module reduction_mod
2 : use shr_kind_mod, only: r8=>shr_kind_r8
3 : use spmd_utils, only: mpi_sum, mpi_min, mpi_max, mpi_real8, mpi_integer
4 : use spmd_utils, only: mpi_success
5 : use cam_abortutils, only: endrun
6 :
7 : implicit none
8 : private
9 :
10 : type, public :: ReductionBuffer_int_1d_t
11 : integer, dimension(:), pointer :: buf
12 : integer :: len=0
13 : integer :: ctr
14 : end type ReductionBuffer_int_1d_t
15 :
16 : type, public :: ReductionBuffer_r_1d_t
17 : real (kind=r8), dimension(:), pointer :: buf
18 : integer :: len=0
19 : integer :: ctr
20 : end type ReductionBuffer_r_1d_t
21 :
22 : type, public :: ReductionBuffer_ordered_1d_t
23 : real (kind=r8), dimension(:,:),pointer :: buf
24 : integer :: len=0
25 : integer :: ctr
26 : end type ReductionBuffer_ordered_1d_t
27 :
28 : public :: ParallelMin
29 : public :: ParallelMax
30 :
31 : type (ReductionBuffer_int_1d_t), public :: red_max_int
32 : type (ReductionBuffer_int_1d_t), public :: red_sum_int
33 : type (ReductionBuffer_r_1d_t), public :: red_flops
34 : type (ReductionBuffer_r_1d_t), public :: red_max
35 : type (ReductionBuffer_r_1d_t), public :: red_min
36 : type (ReductionBuffer_r_1d_t), public :: red_sum
37 : #ifndef Darwin
38 : SAVE red_max_int, red_sum_int, red_flops, red_max, red_min, red_sum
39 : #endif
40 :
41 : interface ParallelMin
42 : module procedure ParallelMin1d
43 : module procedure ParallelMin0d
44 : end interface
45 : interface ParallelMax
46 : module procedure ParallelMax1d_int
47 : module procedure ParallelMax2d_int
48 : module procedure ParallelMax1d
49 : module procedure ParallelMax0d
50 : module procedure ParallelMax0d_int
51 : end interface
52 :
53 : interface pmax_mt
54 : module procedure pmax_mt_int_1d
55 : module procedure pmax_mt_r_1d
56 : end interface
57 :
58 : interface pmin_mt
59 : module procedure pmin_mt_r_1d
60 : end interface
61 :
62 : interface InitReductionBuffer
63 : module procedure InitReductionBuffer_int_1d
64 : module procedure InitReductionBuffer_r_1d
65 : module procedure InitReductionBuffer_ordered_1d
66 : end interface
67 :
68 : public :: InitReductionBuffer
69 : public :: pmax_mt, pmin_mt
70 : public :: ElementSum_1d
71 :
72 : contains
73 :
74 66048 : function ParallelMin1d(data,hybrid) result(pmin)
75 : use hybrid_mod, only : hybrid_t
76 :
77 : real(kind=r8), intent(in) :: data(:)
78 : type (hybrid_t), intent(in) :: hybrid
79 : real(kind=r8) :: pmin
80 :
81 : real(kind=r8) :: tmp(1)
82 :
83 :
84 596496 : tmp(1) = MINVAL(data)
85 66048 : call pmin_mt(red_min,tmp,1,hybrid)
86 66048 : pmin = red_min%buf(1)
87 :
88 66048 : end function ParallelMin1d
89 :
90 6144 : function ParallelMin0d(data,hybrid) result(pmin)
91 : use hybrid_mod, only : hybrid_t
92 : implicit none
93 : real(kind=r8), intent(in) :: data
94 : type (hybrid_t), intent(in) :: hybrid
95 : real(kind=r8) :: pmin
96 : real(kind=r8) :: tmp(1)
97 6144 : tmp(1) = data
98 6144 : call pmin_mt(red_min,tmp,1,hybrid)
99 6144 : pmin = red_min%buf(1)
100 :
101 6144 : end function ParallelMin0d
102 : !==================================================
103 0 : function ParallelMax2d_int(data, n, m, hybrid) result(pmax)
104 : use hybrid_mod, only : hybrid_t
105 : implicit none
106 : integer, intent(in) :: n,m
107 : integer, intent(in), dimension(n,m) :: data
108 : type (hybrid_t), intent(in) :: hybrid
109 : integer, dimension(n,m) :: pmax
110 0 : integer, dimension(n*m) :: tmp
111 : integer :: i,j
112 0 : do i=1,n
113 0 : do j=1,m
114 0 : tmp(i+(j-1)*n) = data(i,j)
115 : enddo
116 : enddo
117 0 : call pmax_mt(red_max_int,tmp,n*m,hybrid)
118 0 : do i=1,n
119 0 : do j=1,m
120 0 : pmax(i,j) = red_max_int%buf(i+(j-1)*n)
121 : enddo
122 : enddo
123 0 : end function ParallelMax2d_int
124 :
125 0 : function ParallelMax1d_int(data, len, hybrid) result(pmax)
126 : use hybrid_mod, only : hybrid_t
127 : implicit none
128 : integer, intent(in) :: len
129 : integer, intent(in), dimension(len) :: data
130 : type (hybrid_t), intent(in) :: hybrid
131 0 : integer, dimension(len) :: pmax, tmp
132 :
133 0 : tmp = data(:)
134 0 : call pmax_mt(red_max_int,tmp,len,hybrid)
135 0 : pmax(:) = red_max_int%buf(1:len)
136 :
137 0 : end function ParallelMax1d_int
138 66048 : function ParallelMax1d(data,hybrid) result(pmax)
139 : use hybrid_mod, only : hybrid_t
140 : implicit none
141 : real(kind=r8), intent(in) :: data(:)
142 : type (hybrid_t), intent(in) :: hybrid
143 : real(kind=r8) :: pmax
144 :
145 : real(kind=r8) :: tmp(1)
146 :
147 :
148 596496 : tmp(1) = MAXVAL(data)
149 66048 : call pmax_mt(red_max,tmp,1,hybrid)
150 66048 : pmax = red_max%buf(1)
151 :
152 66048 : end function ParallelMax1d
153 6144 : function ParallelMax0d(data,hybrid) result(pmax)
154 : use hybrid_mod, only : hybrid_t
155 : implicit none
156 : real(kind=r8), intent(in) :: data
157 : type (hybrid_t), intent(in) :: hybrid
158 : real(kind=r8) :: pmax
159 : real(kind=r8) :: tmp(1)
160 :
161 6144 : tmp(1)=data
162 :
163 6144 : call pmax_mt(red_max,tmp,1,hybrid)
164 6144 : pmax = red_max%buf(1)
165 :
166 6144 : end function ParallelMax0d
167 0 : function ParallelMax0d_int(data,hybrid) result(pmax)
168 : use hybrid_mod, only : hybrid_t
169 : implicit none
170 : integer , intent(in) :: data
171 : type (hybrid_t), intent(in) :: hybrid
172 : integer :: pmax
173 : integer :: tmp(1)
174 :
175 0 : tmp(1)=data
176 :
177 0 : call pmax_mt(red_max_int,tmp,1,hybrid)
178 0 : pmax = red_max_int%buf(1)
179 :
180 0 : end function ParallelMax0d_int
181 : !==================================================
182 3072 : subroutine InitReductionBuffer_int_1d(red,len)
183 : use thread_mod, only: omp_get_num_threads
184 : integer, intent(in) :: len
185 : type (ReductionBuffer_int_1d_t),intent(out) :: red
186 :
187 3072 : if (omp_get_num_threads()>1) then
188 0 : call endrun("Error: attempt to allocate reduction buffer in threaded region")
189 : endif
190 :
191 : ! if buffer is already allocated and large enough, do nothing
192 3072 : if (len > red%len) then
193 : !buffer is too small, or has not yet been allocated
194 3072 : if (red%len>0) deallocate(red%buf)
195 3072 : red%len = len
196 9216 : allocate(red%buf(len))
197 6144 : red%buf = 0
198 3072 : red%ctr = 0
199 : endif
200 :
201 3072 : end subroutine InitReductionBuffer_int_1d
202 : !****************************************************************
203 6144 : subroutine InitReductionBuffer_r_1d(red,len)
204 : use thread_mod, only: omp_get_num_threads
205 : integer, intent(in) :: len
206 : type (ReductionBuffer_r_1d_t),intent(out) :: red
207 :
208 6144 : if (omp_get_num_threads()>1) then
209 0 : call endrun("Error: attempt to allocate reduction buffer in threaded region")
210 : endif
211 :
212 6144 : if (len > red%len) then
213 6144 : if (red%len>0) deallocate(red%buf)
214 6144 : red%len = len
215 18432 : allocate(red%buf(len))
216 18432 : red%buf = 0.0_R8
217 6144 : red%ctr = 0
218 : endif
219 6144 : end subroutine InitReductionBuffer_r_1d
220 : !****************************************************************
221 1536 : subroutine InitReductionBuffer_ordered_1d(red,len,nthread)
222 : use thread_mod, only: omp_get_num_threads
223 : integer, intent(in) :: len
224 : integer, intent(in) :: nthread
225 : type (ReductionBuffer_ordered_1d_t),intent(out) :: red
226 :
227 1536 : if (omp_get_num_threads()>1) then
228 0 : call endrun("Error: attempt to allocate reduction buffer in threaded region")
229 : endif
230 :
231 1536 : if (len > red%len) then
232 1536 : if (red%len>0) deallocate(red%buf)
233 1536 : red%len = len
234 6144 : allocate(red%buf(len,nthread+1))
235 244224 : red%buf = 0.0_R8
236 1536 : red%ctr = 0
237 : endif
238 1536 : end subroutine InitReductionBuffer_ordered_1d
239 :
240 : ! =======================================
241 : ! pmax_mt:
242 : !
243 : ! thread safe, parallel reduce maximum
244 : ! of a one dimensional reduction vector
245 : ! =======================================
246 :
247 0 : subroutine pmax_mt_int_1d(red,redp,len,hybrid)
248 : use hybrid_mod, only : hybrid_t
249 :
250 : type (ReductionBuffer_int_1d_t) :: red ! shared memory reduction buffer struct
251 : integer, intent(in) :: len ! buffer length
252 : integer, intent(inout) :: redp(len) ! thread private vector of partial sum
253 : type (hybrid_t), intent(in) :: hybrid ! parallel handle
254 :
255 : ! Local variables
256 : #ifdef _MPI
257 : integer ierr
258 : #endif
259 :
260 : integer :: k
261 0 : if (len>red%len) then
262 0 : call endrun('ERROR: threadsafe reduction buffer too small')
263 : end if
264 :
265 : !$OMP BARRIER
266 : !$OMP CRITICAL (CRITMAX)
267 0 : if (red%ctr == 0) red%buf(1:len)= -9999
268 0 : if (red%ctr < hybrid%NThreads) then
269 0 : do k=1,len
270 0 : red%buf(k)=MAX(red%buf(k),redp(k))
271 : enddo
272 0 : red%ctr=red%ctr+1
273 : end if
274 0 : if (red%ctr == hybrid%NThreads) red%ctr=0
275 : !$OMP END CRITICAL (CRITMAX)
276 : #ifdef _MPI
277 : !$OMP BARRIER
278 0 : if (hybrid%ithr==0) then
279 :
280 0 : call MPI_Allreduce(red%buf(1),redp,len,Mpi_integer, &
281 0 : MPI_MAX,hybrid%par%comm,ierr)
282 :
283 0 : red%buf(1:len)=redp(1:len)
284 : end if
285 : #endif
286 : !$OMP BARRIER
287 :
288 0 : end subroutine pmax_mt_int_1d
289 :
290 72192 : subroutine pmax_mt_r_1d(red,redp,len,hybrid)
291 : use hybrid_mod, only : hybrid_t
292 :
293 : type (ReductionBuffer_r_1d_t) :: red ! shared memory reduction buffer struct
294 : real (kind=r8), intent(inout) :: redp(:) ! thread private vector of partial sum
295 : integer, intent(in) :: len ! buffer length
296 : type (hybrid_t), intent(in) :: hybrid ! parallel handle
297 :
298 : ! Local variables
299 : #ifdef _MPI
300 : integer ierr
301 : #endif
302 :
303 : integer :: k
304 72192 : if (len>red%len) then
305 0 : call endrun('ERROR: threadsafe reduction buffer too small')
306 : end if
307 :
308 : !$OMP BARRIER
309 : !$OMP CRITICAL (CRITMAX)
310 144384 : if (red%ctr == 0) red%buf(1:len)= -9.11e30_r8
311 72192 : if (red%ctr < hybrid%NThreads) then
312 144384 : do k=1,len
313 144384 : red%buf(k)=MAX(red%buf(k),redp(k))
314 : enddo
315 72192 : red%ctr=red%ctr+1
316 : end if
317 72192 : if (red%ctr == hybrid%NThreads) red%ctr=0
318 : !$OMP END CRITICAL (CRITMAX)
319 : #ifdef _MPI
320 : !$OMP BARRIER
321 72192 : if (hybrid%ithr==0) then
322 :
323 0 : call MPI_Allreduce(red%buf(1),redp,len,Mpi_real8, &
324 72192 : MPI_MAX,hybrid%par%comm,ierr)
325 :
326 144384 : red%buf(1:len)=redp(1:len)
327 : end if
328 : #endif
329 : !$OMP BARRIER
330 :
331 72192 : end subroutine pmax_mt_r_1d
332 :
333 : ! =======================================
334 : ! pmin_mt:
335 : !
336 : ! thread safe, parallel reduce maximum
337 : ! of a one dimensional reduction vector
338 : ! =======================================
339 :
340 72192 : subroutine pmin_mt_r_1d(red,redp,len,hybrid)
341 : use hybrid_mod, only : hybrid_t
342 :
343 : type (ReductionBuffer_r_1d_t) :: red ! shared memory reduction buffer struct
344 : real (kind=r8), intent(inout) :: redp(:) ! thread private vector of partial sum
345 : integer, intent(in) :: len ! buffer length
346 : type (hybrid_t), intent(in) :: hybrid ! parallel handle
347 :
348 : ! Local variables
349 :
350 : #ifdef _MPI
351 : integer :: ierr
352 : #endif
353 : integer :: k
354 :
355 72192 : if (len>red%len) then
356 0 : call endrun('ERROR: threadsafe reduction buffer too small')
357 : end if
358 :
359 : !$OMP BARRIER
360 : !$OMP CRITICAL (CRITMAX)
361 144384 : if (red%ctr == 0) red%buf(1:len)= 9.11e30_r8
362 72192 : if (red%ctr < hybrid%NThreads) then
363 144384 : do k=1,len
364 144384 : red%buf(k)=MIN(red%buf(k),redp(k))
365 : enddo
366 72192 : red%ctr=red%ctr+1
367 : end if
368 72192 : if (red%ctr == hybrid%NThreads) red%ctr=0
369 : !$OMP END CRITICAL (CRITMAX)
370 : #ifdef _MPI
371 : !$OMP BARRIER
372 72192 : if (hybrid%ithr==0) then
373 :
374 0 : call MPI_Allreduce(red%buf(1),redp,len,Mpi_real8, &
375 72192 : MPI_MIN,hybrid%par%comm,ierr)
376 :
377 144384 : red%buf(1:len)=redp(1:len)
378 : end if
379 : #endif
380 : !$OMP BARRIER
381 :
382 72192 : end subroutine pmin_mt_r_1d
383 :
384 0 : subroutine ElementSum_1d(res,variable,type,hybrid)
385 : use hybrid_mod, only: hybrid_t
386 : use dimensions_mod, only: nelem
387 : use parallel_mod, only: ORDERED
388 :
389 : ! ==========================
390 : ! Arguments
391 : ! ==========================
392 : real(kind=r8), intent(out) :: res
393 : real(kind=r8), intent(in) :: variable(:)
394 : integer, intent(in) :: type
395 : type (hybrid_t), intent(in) :: hybrid
396 :
397 : ! ==========================
398 : ! Local Variables
399 : ! ==========================
400 :
401 : !
402 : ! Note this is a real kludge here since it may be used for
403 : ! arrays of size other then nelem
404 : !
405 :
406 : #ifdef _MPI
407 : integer :: errorcode,errorlen
408 : character(len=80) :: errorstring
409 :
410 : real(kind=r8) :: local_sum
411 : integer :: ierr
412 : #else
413 : integer :: i
414 : #endif
415 :
416 : #ifdef _MPI
417 0 : if(hybrid%ithr == 0) then
418 0 : local_sum=SUM(variable)
419 0 : call MPI_Barrier(hybrid%par%comm,ierr)
420 :
421 : call MPI_Allreduce(local_sum,res,1,Mpi_real8, &
422 0 : MPI_SUM,hybrid%par%comm,ierr)
423 0 : if(ierr .ne. MPI_SUCCESS) then
424 0 : errorcode=ierr
425 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
426 0 : print *,'ElementSum_1d: Error after call to MPI_Allreduce: ',errorstring
427 : endif
428 : endif
429 : #else
430 : if(hybrid%ithr == 0) then
431 : if(type == ORDERED) then
432 : ! ===========================
433 : ! Perform the ordererd sum
434 : ! ===========================
435 : res = 0.0_r8
436 : do i=1,nelem
437 : res = res + variable(i)
438 : enddo
439 : else
440 : res=SUM(variable)
441 : endif
442 : endif
443 : #endif
444 :
445 0 : end subroutine ElementSum_1d
446 :
447 0 : end module reduction_mod
|
