Line data Source code
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 : ! **************************************************************************************************
23 : MODULE 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 :
43 : CONTAINS
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 2 : 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 2 : INTEGER, ALLOCATABLE, DIMENSION(:) :: rcount, rdispl, scount, sdispl
65 : LOGICAL :: ionode
66 : REAL(KIND=dp) :: maxdiff, t1, &
67 : t2, t3, t4, t5
68 2 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: buffer1, buffer2, buffer3, &
69 2 : lgrid, lgrid2, lgrid3
70 : REAL(KIND=dp), ALLOCATABLE, &
71 2 : DIMENSION(:, :) :: grid, grid2, grid3, &
72 2 : send_timings, send_timings2
73 : REAL(KIND=dp), PARAMETER :: threshold = 1.0E-8_dp
74 :
75 : ! set system sizes !
76 2 : ngrid = 10**npow
77 :
78 2 : taskid = comm%mepos
79 2 : nprocs = comm%num_pe
80 2 : ionode = comm%is_source()
81 2 : IF (ionode .AND. output_unit > 0) THEN
82 1 : WRITE (output_unit, *) "Running with ", nprocs
83 1 : WRITE (output_unit, *) "running messages with npow = ", npow
84 1 : WRITE (output_unit, *) "use MPI X in the input for larger (e.g. 6) of smaller (e.g. 3) messages"
85 1 : IF (MODULO(nprocs, 2) /= 0) WRITE (output_unit, *) "Testing only with an even number of tasks"
86 : END IF
87 :
88 2 : IF (MODULO(nprocs, 2) /= 0) RETURN
89 :
90 : ! equal loads
91 2 : Nloc = Ngrid/nprocs
92 2 : Ntot = Nprocs*Nloc
93 2 : nbufmax = 10**npow
94 : !
95 6 : ALLOCATE (rcount(nprocs))
96 4 : ALLOCATE (scount(nprocs))
97 4 : ALLOCATE (sdispl(nprocs))
98 4 : ALLOCATE (rdispl(nprocs))
99 6 : ALLOCATE (buffer1(nbufmax))
100 4 : ALLOCATE (buffer2(nbufmax))
101 4 : ALLOCATE (buffer3(nbufmax))
102 8 : ALLOCATE (grid(Nloc, Nprocs))
103 6 : ALLOCATE (grid2(Nloc, Nprocs))
104 6 : ALLOCATE (grid3(Nloc, Nprocs))
105 6 : ALLOCATE (lgrid(Nloc))
106 4 : ALLOCATE (lgrid2(Nloc))
107 4 : ALLOCATE (lgrid3(Nloc))
108 8 : ALLOCATE (send_timings(0:nprocs - 1, 0:nprocs - 1))
109 6 : ALLOCATE (send_timings2(0:nprocs - 1, 0:nprocs - 1))
110 2 : buffer1 = 0.0_dp
111 2 : buffer2 = 0.0_dp
112 2 : buffer3 = 0.0_dp
113 : ! timings
114 2 : send_timings = 0.0_dp
115 2 : send_timings2 = 0.0_dp
116 : ! -------------------------------------------------------------------------------------------
117 : ! ------------------------------ some in memory tests ---------------------
118 : ! -------------------------------------------------------------------------------------------
119 2 : CALL comm%sync()
120 2 : IF (ionode .AND. output_unit > 0) THEN
121 1 : WRITE (output_unit, *) "Testing in memory copies just 1 CPU "
122 1 : WRITE (output_unit, *) " could tell something about the motherboard / cache / compiler "
123 : END IF
124 10 : DO i = 1, npow
125 8 : ncount = 10**i
126 8 : t2 = 0.0E0_dp
127 8 : CPASSERT(ncount <= nbufmax)
128 88 : DO j = 1, 3**(npow - i)
129 80 : CALL comm%sync()
130 80 : t1 = MPI_WTIME()
131 28420 : buffer2(1:ncount) = buffer1(1:ncount)
132 88 : t2 = t2 + MPI_WTIME() - t1 + threshold
133 : END DO
134 8 : CALL comm%max(t2, 0)
135 10 : IF (ionode .AND. output_unit > 0) THEN
136 4 : 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 2 : CALL comm%sync()
143 2 : IF (ionode .AND. output_unit > 0) THEN
144 1 : WRITE (output_unit, *) "Testing in memory copies all cpus"
145 1 : WRITE (output_unit, *) " is the memory bandwidth affected on an SMP machine ?"
146 : END IF
147 10 : DO i = 1, npow
148 8 : ncount = 10**i
149 8 : t2 = 0.0E0_dp
150 8 : CPASSERT(ncount <= nbufmax)
151 88 : DO j = 1, 3**(npow - i)
152 80 : CALL comm%sync()
153 80 : t1 = MPI_WTIME()
154 28420 : buffer2(1:ncount) = buffer1(1:ncount)
155 88 : t2 = t2 + MPI_WTIME() - t1 + threshold
156 : END DO
157 8 : CALL comm%max(t2, 0)
158 10 : IF (ionode .AND. output_unit > 0) THEN
159 4 : 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 2 : CALL comm%sync()
166 2 : IF (ionode .AND. output_unit > 0) THEN
167 1 : WRITE (output_unit, *) "Testing truly point to point communication (i with j only)"
168 1 : WRITE (output_unit, *) " is there some different connection between i j (e.g. shared memory comm)"
169 : END IF
170 2 : ncount = 10**npow
171 2 : IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "For messages of ", ncount*8, " bytes"
172 : CPASSERT(ncount <= nbufmax)
173 6 : DO itask = 0, nprocs - 1
174 8 : DO jtask = itask + 1, nprocs - 1
175 2 : CALL comm%sync()
176 2 : t1 = MPI_WTIME()
177 2 : IF (taskid == itask) THEN
178 1 : CALL comm%send(buffer1, jtask, itask*jtask)
179 : END IF
180 2 : IF (taskid == jtask) THEN
181 1 : source = itask
182 1 : tag = itask*jtask
183 1 : CALL comm%recv(buffer1, source, tag)
184 : END IF
185 6 : send_timings(itask, jtask) = MPI_WTIME() - t1 + threshold
186 : END DO
187 : END DO
188 2 : CALL comm%max(send_timings, 0)
189 2 : IF (ionode .AND. output_unit > 0) THEN
190 3 : DO itask = 0, nprocs - 1
191 4 : DO jtask = itask + 1, nprocs - 1
192 3 : 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 2 : CALL comm%sync()
197 : ! -------------------------------------------------------------------------------------------
198 : ! ------------------------------ second test point to point communication -------------------
199 : ! -------------------------------------------------------------------------------------------
200 2 : IF (ionode .AND. output_unit > 0) THEN
201 1 : WRITE (output_unit, *) "Testing all nearby point to point communication (0,1)(2,3)..."
202 1 : WRITE (output_unit, *) " these could / should all be on the same shared memory node "
203 : END IF
204 10 : DO i = 1, npow
205 8 : ncount = 10**i
206 8 : t2 = 0.0E0_dp
207 8 : CPASSERT(ncount <= nbufmax)
208 88 : DO j = 1, 3**(npow - i)
209 80 : CALL comm%sync()
210 80 : t1 = MPI_WTIME()
211 80 : IF (MODULO(taskid, 2) == 0) THEN
212 40 : CALL comm%send(buffer1, taskid + 1, 0)
213 : ELSE
214 40 : source = taskid - 1
215 40 : tag = 0
216 40 : CALL comm%recv(buffer1, source, tag)
217 : END IF
218 88 : t2 = t2 + MPI_WTIME() - t1 + threshold
219 : END DO
220 8 : CALL comm%max(t2, 0)
221 10 : IF (ionode .AND. output_unit > 0) THEN
222 4 : 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 2 : CALL comm%sync()
226 : ! -------------------------------------------------------------------------------------------
227 : ! ------------------------------ third test point to point communication -------------------
228 : ! -------------------------------------------------------------------------------------------
229 2 : IF (ionode .AND. output_unit > 0) THEN
230 1 : WRITE (output_unit, *) "Testing all far point to point communication (0,nprocs/2),(1,nprocs/2+1),.."
231 1 : WRITE (output_unit, *) " these could all be going over the network, and stress it a lot"
232 : END IF
233 10 : DO i = 1, npow
234 8 : ncount = 10**i
235 8 : t2 = 0.0E0_dp
236 8 : CPASSERT(ncount <= nbufmax)
237 88 : DO j = 1, 3**(npow - i)
238 80 : CALL comm%sync()
239 80 : t1 = MPI_WTIME()
240 : ! first half with partner
241 80 : IF (taskid < nprocs/2) THEN
242 40 : CALL comm%send(buffer1, taskid + nprocs/2, 0)
243 : ELSE
244 40 : source = taskid - nprocs/2
245 40 : tag = 0
246 40 : CALL comm%recv(buffer1, source, tag)
247 : END IF
248 88 : t2 = t2 + MPI_WTIME() - t1 + threshold
249 : END DO
250 8 : CALL comm%max(t2, 0)
251 10 : IF (ionode .AND. output_unit > 0) THEN
252 4 : 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 2 : CALL comm%sync()
259 2 : IF (ionode .AND. output_unit > 0) THEN
260 1 : WRITE (output_unit, *) "Testing root to all broadcast "
261 1 : WRITE (output_unit, *) " using trees at least ? "
262 : END IF
263 10 : DO i = 1, npow
264 8 : ncount = 10**i
265 8 : t2 = 0.0E0_dp
266 8 : CPASSERT(ncount <= nbufmax)
267 88 : DO j = 1, 3**(npow - i)
268 80 : CALL comm%sync()
269 80 : t1 = MPI_WTIME()
270 80 : CALL comm%bcast(buffer1, 0)
271 88 : t2 = t2 + MPI_WTIME() - t1 + threshold
272 : END DO
273 8 : CALL comm%max(t2, 0)
274 10 : IF (ionode .AND. output_unit > 0) THEN
275 4 : 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 2 : CALL comm%sync()
282 2 : IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "Test global summation (mpi_allreduce) "
283 10 : DO i = 1, npow
284 8 : ncount = 10**i
285 8 : t2 = 0.0E0_dp
286 8 : CPASSERT(ncount <= nbufmax)
287 88 : DO j = 1, 3**(npow - i)
288 800080 : buffer2(:) = buffer1
289 80 : CALL comm%sync()
290 80 : t1 = MPI_WTIME()
291 80 : CALL comm%sum(buffer2)
292 88 : t2 = t2 + MPI_WTIME() - t1 + threshold
293 : END DO
294 8 : CALL comm%max(t2, 0)
295 10 : IF (ionode .AND. output_unit > 0) THEN
296 4 : 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 2 : CALL comm%sync()
303 2 : IF (ionode .AND. output_unit > 0) THEN
304 1 : WRITE (output_unit, *) "Test all to all communication (mpi_alltoallv)"
305 1 : WRITE (output_unit, *) " mpi/network getting confused ? "
306 : END IF
307 10 : DO i = 1, npow
308 8 : ncount = 10**i
309 8 : t2 = 0.0E0_dp
310 8 : CPASSERT(ncount <= nbufmax)
311 24 : scount = ncount/nprocs
312 24 : rcount = ncount/nprocs
313 24 : DO j = 1, nprocs
314 16 : sdispl(j) = (j - 1)*(ncount/nprocs)
315 24 : rdispl(j) = (j - 1)*(ncount/nprocs)
316 : END DO
317 88 : DO j = 1, 3**(npow - i)
318 80 : CALL comm%sync()
319 80 : t1 = MPI_WTIME()
320 80 : CALL comm%alltoall(buffer1, scount, sdispl, buffer2, rcount, rdispl)
321 88 : t2 = t2 + MPI_WTIME() - t1 + threshold
322 : END DO
323 8 : CALL comm%max(t2, 0)
324 10 : IF (ionode .AND. output_unit > 0) THEN
325 4 : WRITE (output_unit, '(I9,A,F12.4,A)') 8*(ncount/nprocs)*nprocs, " Bytes ", &
326 8 : (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 2 : IF (ionode .AND. output_unit > 0) THEN
334 1 : WRITE (output_unit, *) " Clean tests completed "
335 1 : WRITE (output_unit, *) " Testing MPI_REDUCE scatter"
336 : END IF
337 6 : rcount = Nloc
338 8 : DO itests = 1, 3
339 6 : IF (ionode .AND. output_unit > 0) THEN
340 3 : WRITE (output_unit, *) "------------------------------- test ", itests, " ------------------------"
341 : END IF
342 : ! *** reference ***
343 18 : DO j = 1, Nprocs
344 60018 : DO i = 1, Nloc
345 60012 : grid(i, j) = MODULO(i*j*taskid, itests)
346 : END DO
347 : END DO
348 6 : t1 = MPI_WTIME()
349 6 : CALL comm%mp_sum_scatter_dv(grid, lgrid, rcount)
350 6 : t2 = MPI_WTIME() - t1 + threshold
351 6 : CALL comm%max(t2)
352 6 : IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "MPI_REDUCE_SCATTER ", t2
353 : ! *** simple shift ***
354 18 : DO j = 1, Nprocs
355 60018 : DO i = 1, Nloc
356 60012 : grid2(i, j) = MODULO(i*j*taskid, itests)
357 : END DO
358 : END DO
359 6 : t3 = MPI_WTIME()
360 6 : lgrid2 = 0.0E0_dp
361 12 : DO i = 1, Nprocs
362 60012 : lgrid2(:) = lgrid2 + grid(:, MODULO(taskid - i, Nprocs) + 1)
363 12 : IF (i == nprocs) EXIT
364 12 : CALL comm%shift(lgrid2, 1)
365 : END DO
366 6 : t4 = MPI_WTIME() - t3 + threshold
367 6 : CALL comm%max(t4)
368 30006 : maxdiff = MAXVAL(ABS(lgrid2 - lgrid))
369 6 : CALL comm%max(maxdiff)
370 6 : IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "MPI_SENDRECV_REPLACE ", t4, maxdiff
371 : ! *** involved shift ****
372 : CPASSERT(MODULO(nprocs, 2) == 0)
373 18 : DO j = 1, Nprocs
374 60018 : DO i = 1, Nloc
375 60012 : grid3(i, j) = MODULO(i*j*taskid, itests)
376 : END DO
377 : END DO
378 6 : 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 6 : IF (MODULO(taskid, 2) == 0) THEN
384 3 : partner = taskid + 1
385 6 : DO i = 1, Nprocs, 2 ! sum the full grid with the partner
386 3 : CALL comm%sendrecv(grid3(:, i + 1), partner, lgrid3, partner, 17)
387 15006 : grid3(:, i) = grid3(:, i) + lgrid3(:)
388 : END DO
389 : ELSE
390 3 : partner = taskid - 1
391 6 : DO i = 1, Nprocs, 2
392 3 : CALL comm%sendrecv(grid3(:, i), partner, lgrid3, partner, 17)
393 15006 : grid3(:, i + 1) = grid3(:, i + 1) + lgrid3(:)
394 : END DO
395 : END IF
396 6 : 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 6 : left = MODULO(taskid - 2, Nprocs)
400 6 : right = MODULO(taskid + 2, Nprocs)
401 6 : t3 = MPI_WTIME()
402 6 : lgrid3 = 0.0E0_dp
403 6 : DO i = 1, Nprocs, 2
404 30006 : lgrid3(:) = lgrid3 + grid3(:, MODULO(taskid - i - 1, Nprocs) + 1)
405 6 : IF (i == nprocs - 1) EXIT
406 6 : CALL comm%shift(lgrid3, 2)
407 : END DO
408 6 : t5 = MPI_WTIME() - t3 + threshold
409 6 : CALL comm%max(t4)
410 6 : CALL comm%max(t5)
411 30006 : maxdiff = MAXVAL(ABS(lgrid3 - lgrid))
412 6 : CALL comm%max(maxdiff)
413 8 : IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "INVOLVED SHIFT ", t4 + t5, "(", t4, ",", t5, ")", maxdiff
414 : END DO
415 2 : DEALLOCATE (rcount)
416 2 : DEALLOCATE (scount)
417 2 : DEALLOCATE (sdispl)
418 2 : DEALLOCATE (rdispl)
419 2 : DEALLOCATE (buffer1)
420 2 : DEALLOCATE (buffer2)
421 2 : DEALLOCATE (buffer3)
422 2 : DEALLOCATE (grid)
423 2 : DEALLOCATE (grid2)
424 2 : DEALLOCATE (grid3)
425 2 : DEALLOCATE (lgrid)
426 2 : DEALLOCATE (lgrid2)
427 2 : DEALLOCATE (lgrid3)
428 2 : DEALLOCATE (send_timings)
429 2 : 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 2 : END SUBROUTINE mpi_perf_test
436 :
437 : END MODULE mp_perf_test
|
