(git:98357aa)
Loading...
Searching...
No Matches
mp_perf_test.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
8! **************************************************************************************************
9!> \brief Interface to the message passing library MPI
10!> \par History
11!> JGH (02-Jan-2001): New error handling
12!> Performance tools
13!> JGH (14-Jan-2001): New routines mp_comm_compare, mp_cart_coords,
14!> mp_rank_compare, mp_alltoall
15!> JGH (06-Feb-2001): New routines mp_comm_free
16!> JGH (22-Mar-2001): New routines mp_comm_dup
17!> fawzi (04-NOV-2004): storable performance info (for f77 interface)
18!> Wrapper routine for mpi_gatherv added (22.12.2005,MK)
19!> JGH (13-Feb-2006): Flexible precision
20!> JGH (15-Feb-2006): single precision mp_alltoall
21!> \author JGH
22! **************************************************************************************************
23MODULE mp_perf_test
24 USE kinds, ONLY: dp
25 USE message_passing, ONLY: mp_comm_type
26 ! some benchmarking code
27#include "../base/base_uses.f90"
28
29#if defined(__parallel)
30#if defined(__MPI_F08)
31 USE mpi_f08, ONLY: mpi_wtime
32#else
33 USE mpi, ONLY: mpi_wtime
34#endif
35#endif
36
37 IMPLICIT NONE
38
39 PRIVATE
40
41 PUBLIC :: mpi_perf_test
42
43CONTAINS
44
45! **************************************************************************************************
46!> \brief Tests the MPI library
47!> \param comm the relevant, initialized communicator
48!> \param npow number of sizes to test, 10**1 .. 10**npow
49!> \param output_unit where to direct output
50!> \par History
51!> JGH 6-Feb-2001 : Test and performance code
52!> \author JGH 1-JAN-2001
53!> \note
54!> quickly adapted benchmark code, will only work on an even number of CPUs.
55! **************************************************************************************************
56 SUBROUTINE mpi_perf_test(comm, npow, output_unit)
57 CLASS(mp_comm_type), INTENT(IN) :: comm
58 INTEGER, INTENT(IN) :: npow, output_unit
59
60#if defined(__parallel)
61
62 INTEGER :: i, itask, itests, j, jtask, left, nbufmax, &
63 ncount, ngrid, nloc, nprocs, ntot, partner, right, taskid, tag, source
64 INTEGER, ALLOCATABLE, DIMENSION(:) :: rcount, rdispl, scount, sdispl
65 LOGICAL :: ionode
66 REAL(kind=dp) :: maxdiff, t1, &
67 t2, t3, t4, t5
68 REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: buffer1, buffer2, buffer3, &
69 lgrid, lgrid2, lgrid3
70 REAL(kind=dp), ALLOCATABLE, &
71 DIMENSION(:, :) :: grid, grid2, grid3, &
72 send_timings, send_timings2
73 REAL(kind=dp), PARAMETER :: threshold = 1.0e-8_dp
74
75 ! set system sizes !
76 ngrid = 10**npow
77
78 taskid = comm%mepos
79 nprocs = comm%num_pe
80 ionode = comm%is_source()
81 IF (ionode .AND. output_unit > 0) THEN
82 WRITE (output_unit, *) "Running with ", nprocs
83 WRITE (output_unit, *) "running messages with npow = ", npow
84 WRITE (output_unit, *) "use MPI X in the input for larger (e.g. 6) of smaller (e.g. 3) messages"
85 IF (modulo(nprocs, 2) /= 0) WRITE (output_unit, *) "Testing only with an even number of tasks"
86 END IF
87
88 IF (modulo(nprocs, 2) /= 0) RETURN
89
90 ! equal loads
91 nloc = ngrid/nprocs
92 ntot = nprocs*nloc
93 nbufmax = 10**npow
94 !
95 ALLOCATE (rcount(nprocs))
96 ALLOCATE (scount(nprocs))
97 ALLOCATE (sdispl(nprocs))
98 ALLOCATE (rdispl(nprocs))
99 ALLOCATE (buffer1(nbufmax))
100 ALLOCATE (buffer2(nbufmax))
101 ALLOCATE (buffer3(nbufmax))
102 ALLOCATE (grid(nloc, nprocs))
103 ALLOCATE (grid2(nloc, nprocs))
104 ALLOCATE (grid3(nloc, nprocs))
105 ALLOCATE (lgrid(nloc))
106 ALLOCATE (lgrid2(nloc))
107 ALLOCATE (lgrid3(nloc))
108 ALLOCATE (send_timings(0:nprocs - 1, 0:nprocs - 1))
109 ALLOCATE (send_timings2(0:nprocs - 1, 0:nprocs - 1))
110 buffer1 = 0.0_dp
111 buffer2 = 0.0_dp
112 buffer3 = 0.0_dp
113 ! timings
114 send_timings = 0.0_dp
115 send_timings2 = 0.0_dp
116 ! -------------------------------------------------------------------------------------------
117 ! ------------------------------ some in memory tests ---------------------
118 ! -------------------------------------------------------------------------------------------
119 CALL comm%sync()
120 IF (ionode .AND. output_unit > 0) THEN
121 WRITE (output_unit, *) "Testing in memory copies just 1 CPU "
122 WRITE (output_unit, *) " could tell something about the motherboard / cache / compiler "
123 END IF
124 DO i = 1, npow
125 ncount = 10**i
126 t2 = 0.0e0_dp
127 cpassert(ncount <= nbufmax)
128 DO j = 1, 3**(npow - i)
129 CALL comm%sync()
130 t1 = mpi_wtime()
131 buffer2(1:ncount) = buffer1(1:ncount)
132 t2 = t2 + mpi_wtime() - t1 + threshold
133 END DO
134 CALL comm%max(t2, 0)
135 IF (ionode .AND. output_unit > 0) THEN
136 WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0e-6_dp/t2, " MB/s"
137 END IF
138 END DO
139 ! -------------------------------------------------------------------------------------------
140 ! ------------------------------ some in memory tests ---------------------
141 ! -------------------------------------------------------------------------------------------
142 CALL comm%sync()
143 IF (ionode .AND. output_unit > 0) THEN
144 WRITE (output_unit, *) "Testing in memory copies all cpus"
145 WRITE (output_unit, *) " is the memory bandwidth affected on an SMP machine ?"
146 END IF
147 DO i = 1, npow
148 ncount = 10**i
149 t2 = 0.0e0_dp
150 cpassert(ncount <= nbufmax)
151 DO j = 1, 3**(npow - i)
152 CALL comm%sync()
153 t1 = mpi_wtime()
154 buffer2(1:ncount) = buffer1(1:ncount)
155 t2 = t2 + mpi_wtime() - t1 + threshold
156 END DO
157 CALL comm%max(t2, 0)
158 IF (ionode .AND. output_unit > 0) THEN
159 WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0e-6_dp/t2, " MB/s"
160 END IF
161 END DO
162 ! -------------------------------------------------------------------------------------------
163 ! ------------------------------ first test point to point communication ---------------------
164 ! -------------------------------------------------------------------------------------------
165 CALL comm%sync()
166 IF (ionode .AND. output_unit > 0) THEN
167 WRITE (output_unit, *) "Testing truly point to point communication (i with j only)"
168 WRITE (output_unit, *) " is there some different connection between i j (e.g. shared memory comm)"
169 END IF
170 ncount = 10**npow
171 IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "For messages of ", ncount*8, " bytes"
172 cpassert(ncount <= nbufmax)
173 DO itask = 0, nprocs - 1
174 DO jtask = itask + 1, nprocs - 1
175 CALL comm%sync()
176 t1 = mpi_wtime()
177 IF (taskid == itask) THEN
178 CALL comm%send(buffer1, jtask, itask*jtask)
179 END IF
180 IF (taskid == jtask) THEN
181 source = itask
182 tag = itask*jtask
183 CALL comm%recv(buffer1, source, tag)
184 END IF
185 send_timings(itask, jtask) = mpi_wtime() - t1 + threshold
186 END DO
187 END DO
188 CALL comm%max(send_timings, 0)
189 IF (ionode .AND. output_unit > 0) THEN
190 DO itask = 0, nprocs - 1
191 DO jtask = itask + 1, nprocs - 1
192 WRITE (output_unit, '(I4,I4,F12.4,A)') itask, jtask, ncount*8.0e-6_dp/send_timings(itask, jtask), " MB/s"
193 END DO
194 END DO
195 END IF
196 CALL comm%sync()
197 ! -------------------------------------------------------------------------------------------
198 ! ------------------------------ second test point to point communication -------------------
199 ! -------------------------------------------------------------------------------------------
200 IF (ionode .AND. output_unit > 0) THEN
201 WRITE (output_unit, *) "Testing all nearby point to point communication (0,1)(2,3)..."
202 WRITE (output_unit, *) " these could / should all be on the same shared memory node "
203 END IF
204 DO i = 1, npow
205 ncount = 10**i
206 t2 = 0.0e0_dp
207 cpassert(ncount <= nbufmax)
208 DO j = 1, 3**(npow - i)
209 CALL comm%sync()
210 t1 = mpi_wtime()
211 IF (modulo(taskid, 2) == 0) THEN
212 CALL comm%send(buffer1, taskid + 1, 0)
213 ELSE
214 source = taskid - 1
215 tag = 0
216 CALL comm%recv(buffer1, source, tag)
217 END IF
218 t2 = t2 + mpi_wtime() - t1 + threshold
219 END DO
220 CALL comm%max(t2, 0)
221 IF (ionode .AND. output_unit > 0) THEN
222 WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0e-6_dp/t2, " MB/s"
223 END IF
224 END DO
225 CALL comm%sync()
226 ! -------------------------------------------------------------------------------------------
227 ! ------------------------------ third test point to point communication -------------------
228 ! -------------------------------------------------------------------------------------------
229 IF (ionode .AND. output_unit > 0) THEN
230 WRITE (output_unit, *) "Testing all far point to point communication (0,nprocs/2),(1,nprocs/2+1),.."
231 WRITE (output_unit, *) " these could all be going over the network, and stress it a lot"
232 END IF
233 DO i = 1, npow
234 ncount = 10**i
235 t2 = 0.0e0_dp
236 cpassert(ncount <= nbufmax)
237 DO j = 1, 3**(npow - i)
238 CALL comm%sync()
239 t1 = mpi_wtime()
240 ! first half with partner
241 IF (taskid < nprocs/2) THEN
242 CALL comm%send(buffer1, taskid + nprocs/2, 0)
243 ELSE
244 source = taskid - nprocs/2
245 tag = 0
246 CALL comm%recv(buffer1, source, tag)
247 END IF
248 t2 = t2 + mpi_wtime() - t1 + threshold
249 END DO
250 CALL comm%max(t2, 0)
251 IF (ionode .AND. output_unit > 0) THEN
252 WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0e-6_dp/t2, " MB/s"
253 END IF
254 END DO
255 ! -------------------------------------------------------------------------------------------
256 ! ------------------------------ test root to all broadcast -------------------
257 ! -------------------------------------------------------------------------------------------
258 CALL comm%sync()
259 IF (ionode .AND. output_unit > 0) THEN
260 WRITE (output_unit, *) "Testing root to all broadcast "
261 WRITE (output_unit, *) " using trees at least ? "
262 END IF
263 DO i = 1, npow
264 ncount = 10**i
265 t2 = 0.0e0_dp
266 cpassert(ncount <= nbufmax)
267 DO j = 1, 3**(npow - i)
268 CALL comm%sync()
269 t1 = mpi_wtime()
270 CALL comm%bcast(buffer1, 0)
271 t2 = t2 + mpi_wtime() - t1 + threshold
272 END DO
273 CALL comm%max(t2, 0)
274 IF (ionode .AND. output_unit > 0) THEN
275 WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0e-6_dp/t2, " MB/s"
276 END IF
277 END DO
278 ! -------------------------------------------------------------------------------------------
279 ! ------------------------------ test parallel sum like behavior -------------------
280 ! -------------------------------------------------------------------------------------------
281 CALL comm%sync()
282 IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "Test global summation (mpi_allreduce) "
283 DO i = 1, npow
284 ncount = 10**i
285 t2 = 0.0e0_dp
286 cpassert(ncount <= nbufmax)
287 DO j = 1, 3**(npow - i)
288 buffer2(:) = buffer1
289 CALL comm%sync()
290 t1 = mpi_wtime()
291 CALL comm%sum(buffer2)
292 t2 = t2 + mpi_wtime() - t1 + threshold
293 END DO
294 CALL comm%max(t2, 0)
295 IF (ionode .AND. output_unit > 0) THEN
296 WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0e-6_dp/t2, " MB/s"
297 END IF
298 END DO
299 ! -------------------------------------------------------------------------------------------
300 ! ------------------------------ test all to all communication -------------------
301 ! -------------------------------------------------------------------------------------------
302 CALL comm%sync()
303 IF (ionode .AND. output_unit > 0) THEN
304 WRITE (output_unit, *) "Test all to all communication (mpi_alltoallv)"
305 WRITE (output_unit, *) " mpi/network getting confused ? "
306 END IF
307 DO i = 1, npow
308 ncount = 10**i
309 t2 = 0.0e0_dp
310 cpassert(ncount <= nbufmax)
311 scount = ncount/nprocs
312 rcount = ncount/nprocs
313 DO j = 1, nprocs
314 sdispl(j) = (j - 1)*(ncount/nprocs)
315 rdispl(j) = (j - 1)*(ncount/nprocs)
316 END DO
317 DO j = 1, 3**(npow - i)
318 CALL comm%sync()
319 t1 = mpi_wtime()
320 CALL comm%alltoall(buffer1, scount, sdispl, buffer2, rcount, rdispl)
321 t2 = t2 + mpi_wtime() - t1 + threshold
322 END DO
323 CALL comm%max(t2, 0)
324 IF (ionode .AND. output_unit > 0) THEN
325 WRITE (output_unit, '(I9,A,F12.4,A)') 8*(ncount/nprocs)*nprocs, " Bytes ", &
326 (3**(npow - i))*(ncount/nprocs)*nprocs*8.0e-6_dp/t2, " MB/s"
327 END IF
328 END DO
329
330 ! -------------------------------------------------------------------------------------------
331 ! ------------------------------ other stuff ---------------------
332 ! -------------------------------------------------------------------------------------------
333 IF (ionode .AND. output_unit > 0) THEN
334 WRITE (output_unit, *) " Clean tests completed "
335 WRITE (output_unit, *) " Testing MPI_REDUCE scatter"
336 END IF
337 rcount = nloc
338 DO itests = 1, 3
339 IF (ionode .AND. output_unit > 0) THEN
340 WRITE (output_unit, *) "------------------------------- test ", itests, " ------------------------"
341 END IF
342 ! *** reference ***
343 DO j = 1, nprocs
344 DO i = 1, nloc
345 grid(i, j) = modulo(i*j*taskid, itests)
346 END DO
347 END DO
348 t1 = mpi_wtime()
349 CALL comm%mp_sum_scatter_dv(grid, lgrid, rcount)
350 t2 = mpi_wtime() - t1 + threshold
351 CALL comm%max(t2)
352 IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "MPI_REDUCE_SCATTER ", t2
353 ! *** simple shift ***
354 DO j = 1, nprocs
355 DO i = 1, nloc
356 grid2(i, j) = modulo(i*j*taskid, itests)
357 END DO
358 END DO
359 t3 = mpi_wtime()
360 lgrid2 = 0.0e0_dp
361 DO i = 1, nprocs
362 lgrid2(:) = lgrid2 + grid(:, modulo(taskid - i, nprocs) + 1)
363 IF (i == nprocs) EXIT
364 CALL comm%shift(lgrid2, 1)
365 END DO
366 t4 = mpi_wtime() - t3 + threshold
367 CALL comm%max(t4)
368 maxdiff = maxval(abs(lgrid2 - lgrid))
369 CALL comm%max(maxdiff)
370 IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "MPI_SENDRECV_REPLACE ", t4, maxdiff
371 ! *** involved shift ****
372 cpassert(modulo(nprocs, 2) == 0)
373 DO j = 1, nprocs
374 DO i = 1, nloc
375 grid3(i, j) = modulo(i*j*taskid, itests)
376 END DO
377 END DO
378 t3 = mpi_wtime()
379 ! first sum the grid in pairs (0,1),(2,3) should be within an LPAR and fast XXXXXXXXX
380 ! 0 will only need parts 0,2,4,... correctly summed
381 ! 1 will only need parts 1,3,5,... correctly summed
382 ! *** could nicely be generalised ****
383 IF (modulo(taskid, 2) == 0) THEN
384 partner = taskid + 1
385 DO i = 1, nprocs, 2 ! sum the full grid with the partner
386 CALL comm%sendrecv(grid3(:, i + 1), partner, lgrid3, partner, 17)
387 grid3(:, i) = grid3(:, i) + lgrid3(:)
388 END DO
389 ELSE
390 partner = taskid - 1
391 DO i = 1, nprocs, 2
392 CALL comm%sendrecv(grid3(:, i), partner, lgrid3, partner, 17)
393 grid3(:, i + 1) = grid3(:, i + 1) + lgrid3(:)
394 END DO
395 END IF
396 t4 = mpi_wtime() - t3 + threshold
397 ! now send a given buffer from 1 to 3 to 5 .. adding the right part of the data
398 ! since we've summed an lgrid does only need to pass by even or odd tasks
399 left = modulo(taskid - 2, nprocs)
400 right = modulo(taskid + 2, nprocs)
401 t3 = mpi_wtime()
402 lgrid3 = 0.0e0_dp
403 DO i = 1, nprocs, 2
404 lgrid3(:) = lgrid3 + grid3(:, modulo(taskid - i - 1, nprocs) + 1)
405 IF (i == nprocs - 1) EXIT
406 CALL comm%shift(lgrid3, 2)
407 END DO
408 t5 = mpi_wtime() - t3 + threshold
409 CALL comm%max(t4)
410 CALL comm%max(t5)
411 maxdiff = maxval(abs(lgrid3 - lgrid))
412 CALL comm%max(maxdiff)
413 IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "INVOLVED SHIFT ", t4 + t5, "(", t4, ",", t5, ")", maxdiff
414 END DO
415 DEALLOCATE (rcount)
416 DEALLOCATE (scount)
417 DEALLOCATE (sdispl)
418 DEALLOCATE (rdispl)
419 DEALLOCATE (buffer1)
420 DEALLOCATE (buffer2)
421 DEALLOCATE (buffer3)
422 DEALLOCATE (grid)
423 DEALLOCATE (grid2)
424 DEALLOCATE (grid3)
425 DEALLOCATE (lgrid)
426 DEALLOCATE (lgrid2)
427 DEALLOCATE (lgrid3)
428 DEALLOCATE (send_timings)
429 DEALLOCATE (send_timings2)
430#else
431 mark_used(comm)
432 mark_used(npow)
433 IF (output_unit > 0) WRITE (output_unit, *) "No MPI tests for a serial program"
434#endif
435 END SUBROUTINE mpi_perf_test
436
437END MODULE mp_perf_test
modulo
static GRID_HOST_DEVICE int modulo(int a, int m)
Equivalent of Fortran's MODULO, which always return a positive number. https://gcc....
Definition grid_common.h:125
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:23
mp_perf_test
Interface to the message passing library MPI.
Definition mp_perf_test.F:23
mp_perf_test::mpi_perf_test
subroutine, public mpi_perf_test(comm, npow, output_unit)
Tests the MPI library.
Definition mp_perf_test.F:57
message_passing::mp_comm_type
Definition message_passing.F:161