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 : #:mute
8 : #:set nametype1 = ['i', 'l', 'd', 'r', 'z', 'c']
9 : #:set type1 = ['INTEGER(KIND=int_4)', 'INTEGER(KIND=int_8)', 'REAL(kind=real_8)', 'REAL(kind=real_4)', 'COMPLEX(kind=real_8)', 'COMPLEX(kind=real_4)']
10 : #:set mpi_type1 = ['MPI_INTEGER', 'MPI_INTEGER8', 'MPI_DOUBLE_PRECISION', 'MPI_REAL', 'MPI_DOUBLE_COMPLEX', 'MPI_COMPLEX']
11 : #:set mpi_2type1 = ['MPI_2INTEGER', 'MPI_INTEGER8', 'MPI_2DOUBLE_PRECISION', 'MPI_2REAL', 'MPI_2DOUBLE_COMPLEX', 'MPI_2COMPLEX']
12 : #:set kind1 = ['int_4', 'int_8', 'real_8', 'real_4', 'real_8', 'real_4']
13 : #:set bytes1 = ['int_4_size','int_8_size','real_8_size','real_4_size','(2*real_8_size)','(2*real_4_size)']
14 : #:set handle1 = ['17', '19', '3', '1', '7', '5']
15 : #:set zero1 = ['0_int_4', '0_int_8', '0.0_real_8', '0.0_real_4', 'CMPLX(0.0, 0.0, real_8)', 'CMPLX(0.0, 0.0, real_4)']
16 : #:set one1 = ['1_int_4', '1_int_8', '1.0_real_8', '1.0_real_4', 'CMPLX(1.0, 0.0, real_8)', 'CMPLX(1.0, 0.0, real_4)']
17 : #:set inst_params = list(zip(nametype1, type1, mpi_type1, mpi_2type1, kind1, bytes1, handle1, zero1, one1))
18 : #:endmute
19 : #:for nametype1, type1, mpi_type1, mpi_2type1, kind1, bytes1, handle1, zero1, one1 in inst_params
20 : ! **************************************************************************************************
21 : !> \brief Shift around the data in msg
22 : !> \param[in,out] msg Rank-2 data to shift
23 : !> \param[in] comm message passing environment identifier
24 : !> \param[in] displ_in displacements (?)
25 : !> \par Example
26 : !> msg will be moved from rank to rank+displ_in (in a circular way)
27 : !> \par Limitations
28 : !> * displ_in will be 1 by default (others not tested)
29 : !> * the message array needs to be the same size on all processes
30 : ! **************************************************************************************************
31 3588 : SUBROUTINE mp_shift_${nametype1}$m(msg, comm, displ_in)
32 :
33 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
34 : CLASS(mp_comm_type), INTENT(IN) :: comm
35 : INTEGER, INTENT(IN), OPTIONAL :: displ_in
36 :
37 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_shift_${nametype1}$m'
38 :
39 : INTEGER :: handle, ierror
40 : #if defined(__parallel)
41 : INTEGER :: displ, left, &
42 : msglen, myrank, nprocs, &
43 : right, tag
44 : #endif
45 :
46 : ierror = 0
47 1196 : CALL mp_timeset(routineN, handle)
48 :
49 : #if defined(__parallel)
50 1196 : CALL mpi_comm_rank(comm%handle, myrank, ierror)
51 1196 : IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routineN)
52 1196 : CALL mpi_comm_size(comm%handle, nprocs, ierror)
53 1196 : IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routineN)
54 1196 : IF (PRESENT(displ_in)) THEN
55 0 : displ = displ_in
56 : ELSE
57 : displ = 1
58 : END IF
59 1196 : right = MODULO(myrank + displ, nprocs)
60 1196 : left = MODULO(myrank - displ, nprocs)
61 1196 : tag = 17
62 3588 : msglen = SIZE(msg)
63 : CALL mpi_sendrecv_replace(msg, msglen, ${mpi_type1}$, right, tag, left, tag, &
64 1196 : comm%handle, MPI_STATUS_IGNORE, ierror)
65 1196 : IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routineN)
66 1196 : CALL add_perf(perf_id=7, count=1, msg_size=msglen*${bytes1}$)
67 : #else
68 : MARK_USED(msg)
69 : MARK_USED(comm)
70 : MARK_USED(displ_in)
71 : #endif
72 1196 : CALL mp_timestop(handle)
73 :
74 1196 : END SUBROUTINE mp_shift_${nametype1}$m
75 :
76 : ! **************************************************************************************************
77 : !> \brief Shift around the data in msg
78 : !> \param[in,out] msg Data to shift
79 : !> \param[in] comm message passing environment identifier
80 : !> \param[in] displ_in displacements (?)
81 : !> \par Example
82 : !> msg will be moved from rank to rank+displ_in (in a circular way)
83 : !> \par Limitations
84 : !> * displ_in will be 1 by default (others not tested)
85 : !> * the message array needs to be the same size on all processes
86 : ! **************************************************************************************************
87 10770 : SUBROUTINE mp_shift_${nametype1}$ (msg, comm, displ_in)
88 :
89 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:)
90 : CLASS(mp_comm_type), INTENT(IN) :: comm
91 : INTEGER, INTENT(IN), OPTIONAL :: displ_in
92 :
93 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_shift_${nametype1}$'
94 :
95 : INTEGER :: handle, ierror
96 : #if defined(__parallel)
97 : INTEGER :: displ, left, &
98 : msglen, myrank, nprocs, &
99 : right, tag
100 : #endif
101 :
102 : ierror = 0
103 3590 : CALL mp_timeset(routineN, handle)
104 :
105 : #if defined(__parallel)
106 3590 : CALL mpi_comm_rank(comm%handle, myrank, ierror)
107 3590 : IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_rank @ "//routineN)
108 3590 : CALL mpi_comm_size(comm%handle, nprocs, ierror)
109 3590 : IF (ierror /= 0) CALL mp_stop(ierror, "mpi_comm_size @ "//routineN)
110 3590 : IF (PRESENT(displ_in)) THEN
111 6 : displ = displ_in
112 : ELSE
113 : displ = 1
114 : END IF
115 3590 : right = MODULO(myrank + displ, nprocs)
116 3590 : left = MODULO(myrank - displ, nprocs)
117 3590 : tag = 19
118 3590 : msglen = SIZE(msg)
119 : CALL mpi_sendrecv_replace(msg, msglen, ${mpi_type1}$, right, tag, left, &
120 3590 : tag, comm%handle, MPI_STATUS_IGNORE, ierror)
121 3590 : IF (ierror /= 0) CALL mp_stop(ierror, "mpi_sendrecv_replace @ "//routineN)
122 3590 : CALL add_perf(perf_id=7, count=1, msg_size=msglen*${bytes1}$)
123 : #else
124 : MARK_USED(msg)
125 : MARK_USED(comm)
126 : MARK_USED(displ_in)
127 : #endif
128 3590 : CALL mp_timestop(handle)
129 :
130 3590 : END SUBROUTINE mp_shift_${nametype1}$
131 :
132 : ! **************************************************************************************************
133 : !> \brief All-to-all data exchange, rank-1 data of different sizes
134 : !> \param[in] sb Data to send
135 : !> \param[in] scount Data counts for data sent to other processes
136 : !> \param[in] sdispl Respective data offsets for data sent to process
137 : !> \param[in,out] rb Buffer into which to receive data
138 : !> \param[in] rcount Data counts for data received from other
139 : !> processes
140 : !> \param[in] rdispl Respective data offsets for data received from
141 : !> other processes
142 : !> \param[in] comm Message passing environment identifier
143 : !> \par MPI mapping
144 : !> mpi_alltoallv
145 : !> \par Array sizes
146 : !> The scount, rcount, and the sdispl and rdispl arrays have a
147 : !> size equal to the number of processes.
148 : !> \par Offsets
149 : !> Values in sdispl and rdispl start with 0.
150 : ! **************************************************************************************************
151 78982 : SUBROUTINE mp_alltoall_${nametype1}$11v(sb, scount, sdispl, rb, rcount, rdispl, comm)
152 :
153 : ${type1}$, DIMENSION(:), INTENT(IN), CONTIGUOUS :: sb
154 : INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
155 : ${type1}$, DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: rb
156 : INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
157 : CLASS(mp_comm_type), INTENT(IN) :: comm
158 :
159 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$11v'
160 :
161 : INTEGER :: handle
162 : #if defined(__parallel)
163 : INTEGER :: ierr, msglen
164 : #else
165 : INTEGER :: i
166 : #endif
167 :
168 78982 : CALL mp_timeset(routineN, handle)
169 :
170 : #if defined(__parallel)
171 : CALL mpi_alltoallv(sb, scount, sdispl, ${mpi_type1}$, &
172 78982 : rb, rcount, rdispl, ${mpi_type1}$, comm%handle, ierr)
173 78982 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routineN)
174 393560 : msglen = SUM(scount) + SUM(rcount)
175 78982 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*${bytes1}$)
176 : #else
177 : MARK_USED(comm)
178 : MARK_USED(scount)
179 : MARK_USED(sdispl)
180 : !$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i) SHARED(rcount,rdispl,sdispl,rb,sb)
181 : DO i = 1, rcount(1)
182 : rb(rdispl(1) + i) = sb(sdispl(1) + i)
183 : END DO
184 : #endif
185 78982 : CALL mp_timestop(handle)
186 :
187 78982 : END SUBROUTINE mp_alltoall_${nametype1}$11v
188 :
189 : ! **************************************************************************************************
190 : !> \brief All-to-all data exchange, rank-2 data of different sizes
191 : !> \param sb ...
192 : !> \param scount ...
193 : !> \param sdispl ...
194 : !> \param rb ...
195 : !> \param rcount ...
196 : !> \param rdispl ...
197 : !> \param comm ...
198 : !> \par MPI mapping
199 : !> mpi_alltoallv
200 : !> \note see mp_alltoall_${nametype1}$11v
201 : ! **************************************************************************************************
202 2826312 : SUBROUTINE mp_alltoall_${nametype1}$22v(sb, scount, sdispl, rb, rcount, rdispl, comm)
203 :
204 : ${type1}$, DIMENSION(:, :), &
205 : INTENT(IN), CONTIGUOUS :: sb
206 : INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: scount, sdispl
207 : ${type1}$, DIMENSION(:, :), CONTIGUOUS, &
208 : INTENT(INOUT) :: rb
209 : INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS :: rcount, rdispl
210 : CLASS(mp_comm_type), INTENT(IN) :: comm
211 :
212 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$22v'
213 :
214 : INTEGER :: handle
215 : #if defined(__parallel)
216 : INTEGER :: ierr, msglen
217 : #endif
218 :
219 2826312 : CALL mp_timeset(routineN, handle)
220 :
221 : #if defined(__parallel)
222 : CALL mpi_alltoallv(sb, scount, sdispl, ${mpi_type1}$, &
223 2826312 : rb, rcount, rdispl, ${mpi_type1}$, comm%handle, ierr)
224 2826312 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoallv @ "//routineN)
225 16957872 : msglen = SUM(scount) + SUM(rcount)
226 2826312 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*2*${bytes1}$)
227 : #else
228 : MARK_USED(comm)
229 : MARK_USED(scount)
230 : MARK_USED(sdispl)
231 : MARK_USED(rcount)
232 : MARK_USED(rdispl)
233 : rb = sb
234 : #endif
235 2826312 : CALL mp_timestop(handle)
236 :
237 2826312 : END SUBROUTINE mp_alltoall_${nametype1}$22v
238 :
239 : ! **************************************************************************************************
240 : !> \brief All-to-all data exchange, rank 1 arrays, equal sizes
241 : !> \param[in] sb array with data to send
242 : !> \param[out] rb array into which data is received
243 : !> \param[in] count number of elements to send/receive (product of the
244 : !> extents of the first two dimensions)
245 : !> \param[in] comm Message passing environment identifier
246 : !> \par Index meaning
247 : !> \par The first two indices specify the data while the last index counts
248 : !> the processes
249 : !> \par Sizes of ranks
250 : !> All processes have the same data size.
251 : !> \par MPI mapping
252 : !> mpi_alltoall
253 : ! **************************************************************************************************
254 1608468 : SUBROUTINE mp_alltoall_${nametype1}$ (sb, rb, count, comm)
255 :
256 : ${type1}$, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sb
257 : ${type1}$, DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rb
258 : INTEGER, INTENT(IN) :: count
259 : CLASS(mp_comm_type), INTENT(IN) :: comm
260 :
261 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$'
262 :
263 : INTEGER :: handle
264 : #if defined(__parallel)
265 : INTEGER :: ierr, msglen, np
266 : #endif
267 :
268 804234 : CALL mp_timeset(routineN, handle)
269 :
270 : #if defined(__parallel)
271 : CALL mpi_alltoall(sb, count, ${mpi_type1}$, &
272 804234 : rb, count, ${mpi_type1}$, comm%handle, ierr)
273 804234 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routineN)
274 804234 : CALL mpi_comm_size(comm%handle, np, ierr)
275 804234 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routineN)
276 804234 : msglen = 2*count*np
277 804234 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*${bytes1}$)
278 : #else
279 : MARK_USED(count)
280 : MARK_USED(comm)
281 : rb = sb
282 : #endif
283 804234 : CALL mp_timestop(handle)
284 :
285 804234 : END SUBROUTINE mp_alltoall_${nametype1}$
286 :
287 : ! **************************************************************************************************
288 : !> \brief All-to-all data exchange, rank-2 arrays, equal sizes
289 : !> \param sb ...
290 : !> \param rb ...
291 : !> \param count ...
292 : !> \param commp ...
293 : !> \note see mp_alltoall_${nametype1}$
294 : ! **************************************************************************************************
295 10952 : SUBROUTINE mp_alltoall_${nametype1}$22(sb, rb, count, comm)
296 :
297 : ${type1}$, DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sb
298 : ${type1}$, DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: rb
299 : INTEGER, INTENT(IN) :: count
300 : CLASS(mp_comm_type), INTENT(IN) :: comm
301 :
302 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$22'
303 :
304 : INTEGER :: handle
305 : #if defined(__parallel)
306 : INTEGER :: ierr, msglen, np
307 : #endif
308 :
309 5476 : CALL mp_timeset(routineN, handle)
310 :
311 : #if defined(__parallel)
312 : CALL mpi_alltoall(sb, count, ${mpi_type1}$, &
313 5476 : rb, count, ${mpi_type1}$, comm%handle, ierr)
314 5476 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routineN)
315 5476 : CALL mpi_comm_size(comm%handle, np, ierr)
316 5476 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routineN)
317 16428 : msglen = 2*SIZE(sb)*np
318 5476 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*${bytes1}$)
319 : #else
320 : MARK_USED(count)
321 : MARK_USED(comm)
322 : rb = sb
323 : #endif
324 5476 : CALL mp_timestop(handle)
325 :
326 5476 : END SUBROUTINE mp_alltoall_${nametype1}$22
327 :
328 : ! **************************************************************************************************
329 : !> \brief All-to-all data exchange, rank-3 data with equal sizes
330 : !> \param sb ...
331 : !> \param rb ...
332 : !> \param count ...
333 : !> \param comm ...
334 : !> \note see mp_alltoall_${nametype1}$
335 : ! **************************************************************************************************
336 0 : SUBROUTINE mp_alltoall_${nametype1}$33(sb, rb, count, comm)
337 :
338 : ${type1}$, DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN) :: sb
339 : ${type1}$, DIMENSION(:, :, :), CONTIGUOUS, INTENT(OUT) :: rb
340 : INTEGER, INTENT(IN) :: count
341 : CLASS(mp_comm_type), INTENT(IN) :: comm
342 :
343 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$33'
344 :
345 : INTEGER :: handle
346 : #if defined(__parallel)
347 : INTEGER :: ierr, msglen, np
348 : #endif
349 :
350 0 : CALL mp_timeset(routineN, handle)
351 :
352 : #if defined(__parallel)
353 : CALL mpi_alltoall(sb, count, ${mpi_type1}$, &
354 0 : rb, count, ${mpi_type1}$, comm%handle, ierr)
355 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routineN)
356 0 : CALL mpi_comm_size(comm%handle, np, ierr)
357 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routineN)
358 0 : msglen = 2*count*np
359 0 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*${bytes1}$)
360 : #else
361 : MARK_USED(count)
362 : MARK_USED(comm)
363 : rb = sb
364 : #endif
365 0 : CALL mp_timestop(handle)
366 :
367 0 : END SUBROUTINE mp_alltoall_${nametype1}$33
368 :
369 : ! **************************************************************************************************
370 : !> \brief All-to-all data exchange, rank 4 data, equal sizes
371 : !> \param sb ...
372 : !> \param rb ...
373 : !> \param count ...
374 : !> \param comm ...
375 : !> \note see mp_alltoall_${nametype1}$
376 : ! **************************************************************************************************
377 0 : SUBROUTINE mp_alltoall_${nametype1}$44(sb, rb, count, comm)
378 :
379 : ${type1}$, DIMENSION(:, :, :, :), CONTIGUOUS, &
380 : INTENT(IN) :: sb
381 : ${type1}$, DIMENSION(:, :, :, :), CONTIGUOUS, &
382 : INTENT(OUT) :: rb
383 : INTEGER, INTENT(IN) :: count
384 : CLASS(mp_comm_type), INTENT(IN) :: comm
385 :
386 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$44'
387 :
388 : INTEGER :: handle
389 : #if defined(__parallel)
390 : INTEGER :: ierr, msglen, np
391 : #endif
392 :
393 0 : CALL mp_timeset(routineN, handle)
394 :
395 : #if defined(__parallel)
396 : CALL mpi_alltoall(sb, count, ${mpi_type1}$, &
397 0 : rb, count, ${mpi_type1}$, comm%handle, ierr)
398 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routineN)
399 0 : CALL mpi_comm_size(comm%handle, np, ierr)
400 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routineN)
401 0 : msglen = 2*count*np
402 0 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*${bytes1}$)
403 : #else
404 : MARK_USED(count)
405 : MARK_USED(comm)
406 : rb = sb
407 : #endif
408 0 : CALL mp_timestop(handle)
409 :
410 0 : END SUBROUTINE mp_alltoall_${nametype1}$44
411 :
412 : ! **************************************************************************************************
413 : !> \brief All-to-all data exchange, rank 5 data, equal sizes
414 : !> \param sb ...
415 : !> \param rb ...
416 : !> \param count ...
417 : !> \param comm ...
418 : !> \note see mp_alltoall_${nametype1}$
419 : ! **************************************************************************************************
420 0 : SUBROUTINE mp_alltoall_${nametype1}$55(sb, rb, count, comm)
421 :
422 : ${type1}$, DIMENSION(:, :, :, :, :), CONTIGUOUS, &
423 : INTENT(IN) :: sb
424 : ${type1}$, DIMENSION(:, :, :, :, :), CONTIGUOUS, &
425 : INTENT(OUT) :: rb
426 : INTEGER, INTENT(IN) :: count
427 : CLASS(mp_comm_type), INTENT(IN) :: comm
428 :
429 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$55'
430 :
431 : INTEGER :: handle
432 : #if defined(__parallel)
433 : INTEGER :: ierr, msglen, np
434 : #endif
435 :
436 0 : CALL mp_timeset(routineN, handle)
437 :
438 : #if defined(__parallel)
439 : CALL mpi_alltoall(sb, count, ${mpi_type1}$, &
440 0 : rb, count, ${mpi_type1}$, comm%handle, ierr)
441 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routineN)
442 0 : CALL mpi_comm_size(comm%handle, np, ierr)
443 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routineN)
444 0 : msglen = 2*count*np
445 0 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*${bytes1}$)
446 : #else
447 : MARK_USED(count)
448 : MARK_USED(comm)
449 : rb = sb
450 : #endif
451 0 : CALL mp_timestop(handle)
452 :
453 0 : END SUBROUTINE mp_alltoall_${nametype1}$55
454 :
455 : ! **************************************************************************************************
456 : !> \brief All-to-all data exchange, rank-4 data to rank-5 data
457 : !> \param sb ...
458 : !> \param rb ...
459 : !> \param count ...
460 : !> \param comm ...
461 : !> \note see mp_alltoall_${nametype1}$
462 : !> \note User must ensure size consistency.
463 : ! **************************************************************************************************
464 25716 : SUBROUTINE mp_alltoall_${nametype1}$45(sb, rb, count, comm)
465 :
466 : ${type1}$, DIMENSION(:, :, :, :), CONTIGUOUS, &
467 : INTENT(IN) :: sb
468 : ${type1}$, &
469 : DIMENSION(:, :, :, :, :), INTENT(OUT), CONTIGUOUS :: rb
470 : INTEGER, INTENT(IN) :: count
471 : CLASS(mp_comm_type), INTENT(IN) :: comm
472 :
473 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$45'
474 :
475 : INTEGER :: handle
476 : #if defined(__parallel)
477 : INTEGER :: ierr, msglen, np
478 : #endif
479 :
480 12858 : CALL mp_timeset(routineN, handle)
481 :
482 : #if defined(__parallel)
483 : CALL mpi_alltoall(sb, count, ${mpi_type1}$, &
484 12858 : rb, count, ${mpi_type1}$, comm%handle, ierr)
485 12858 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routineN)
486 12858 : CALL mpi_comm_size(comm%handle, np, ierr)
487 12858 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routineN)
488 12858 : msglen = 2*count*np
489 12858 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*${bytes1}$)
490 : #else
491 : MARK_USED(count)
492 : MARK_USED(comm)
493 : rb = RESHAPE(sb, SHAPE(rb))
494 : #endif
495 12858 : CALL mp_timestop(handle)
496 :
497 12858 : END SUBROUTINE mp_alltoall_${nametype1}$45
498 :
499 : ! **************************************************************************************************
500 : !> \brief All-to-all data exchange, rank-3 data to rank-4 data
501 : !> \param sb ...
502 : !> \param rb ...
503 : !> \param count ...
504 : !> \param comm ...
505 : !> \note see mp_alltoall_${nametype1}$
506 : !> \note User must ensure size consistency.
507 : ! **************************************************************************************************
508 4 : SUBROUTINE mp_alltoall_${nametype1}$34(sb, rb, count, comm)
509 :
510 : ${type1}$, DIMENSION(:, :, :), CONTIGUOUS, &
511 : INTENT(IN) :: sb
512 : ${type1}$, DIMENSION(:, :, :, :), CONTIGUOUS, &
513 : INTENT(OUT) :: rb
514 : INTEGER, INTENT(IN) :: count
515 : CLASS(mp_comm_type), INTENT(IN) :: comm
516 :
517 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$34'
518 :
519 : INTEGER :: handle
520 : #if defined(__parallel)
521 : INTEGER :: ierr, msglen, np
522 : #endif
523 :
524 2 : CALL mp_timeset(routineN, handle)
525 :
526 : #if defined(__parallel)
527 : CALL mpi_alltoall(sb, count, ${mpi_type1}$, &
528 2 : rb, count, ${mpi_type1}$, comm%handle, ierr)
529 2 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routineN)
530 2 : CALL mpi_comm_size(comm%handle, np, ierr)
531 2 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routineN)
532 2 : msglen = 2*count*np
533 2 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*${bytes1}$)
534 : #else
535 : MARK_USED(count)
536 : MARK_USED(comm)
537 : rb = RESHAPE(sb, SHAPE(rb))
538 : #endif
539 2 : CALL mp_timestop(handle)
540 :
541 2 : END SUBROUTINE mp_alltoall_${nametype1}$34
542 :
543 : ! **************************************************************************************************
544 : !> \brief All-to-all data exchange, rank-5 data to rank-4 data
545 : !> \param sb ...
546 : !> \param rb ...
547 : !> \param count ...
548 : !> \param comm ...
549 : !> \note see mp_alltoall_${nametype1}$
550 : !> \note User must ensure size consistency.
551 : ! **************************************************************************************************
552 25028 : SUBROUTINE mp_alltoall_${nametype1}$54(sb, rb, count, comm)
553 :
554 : ${type1}$, &
555 : DIMENSION(:, :, :, :, :), CONTIGUOUS, INTENT(IN) :: sb
556 : ${type1}$, DIMENSION(:, :, :, :), CONTIGUOUS, &
557 : INTENT(OUT) :: rb
558 : INTEGER, INTENT(IN) :: count
559 : CLASS(mp_comm_type), INTENT(IN) :: comm
560 :
561 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_alltoall_${nametype1}$54'
562 :
563 : INTEGER :: handle
564 : #if defined(__parallel)
565 : INTEGER :: ierr, msglen, np
566 : #endif
567 :
568 12514 : CALL mp_timeset(routineN, handle)
569 :
570 : #if defined(__parallel)
571 : CALL mpi_alltoall(sb, count, ${mpi_type1}$, &
572 12514 : rb, count, ${mpi_type1}$, comm%handle, ierr)
573 12514 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_alltoall @ "//routineN)
574 12514 : CALL mpi_comm_size(comm%handle, np, ierr)
575 12514 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ "//routineN)
576 12514 : msglen = 2*count*np
577 12514 : CALL add_perf(perf_id=6, count=1, msg_size=msglen*${bytes1}$)
578 : #else
579 : MARK_USED(count)
580 : MARK_USED(comm)
581 : rb = RESHAPE(sb, SHAPE(rb))
582 : #endif
583 12514 : CALL mp_timestop(handle)
584 :
585 12514 : END SUBROUTINE mp_alltoall_${nametype1}$54
586 :
587 : ! **************************************************************************************************
588 : !> \brief Send one datum to another process
589 : !> \param[in] msg Scalar to send
590 : !> \param[in] dest Destination process
591 : !> \param[in] tag Transfer identifier
592 : !> \param[in] comm Message passing environment identifier
593 : !> \par MPI mapping
594 : !> mpi_send
595 : ! **************************************************************************************************
596 1070 : SUBROUTINE mp_send_${nametype1}$ (msg, dest, tag, comm)
597 : ${type1}$, INTENT(IN) :: msg
598 : INTEGER, INTENT(IN) :: dest, tag
599 : CLASS(mp_comm_type), INTENT(IN) :: comm
600 :
601 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_send_${nametype1}$'
602 :
603 : INTEGER :: handle
604 : #if defined(__parallel)
605 : INTEGER :: ierr, msglen
606 : #endif
607 :
608 1070 : CALL mp_timeset(routineN, handle)
609 :
610 : #if defined(__parallel)
611 1070 : msglen = 1
612 1070 : CALL mpi_send(msg, msglen, ${mpi_type1}$, dest, tag, comm%handle, ierr)
613 1070 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routineN)
614 1070 : CALL add_perf(perf_id=13, count=1, msg_size=msglen*${bytes1}$)
615 : #else
616 : MARK_USED(msg)
617 : MARK_USED(dest)
618 : MARK_USED(tag)
619 : MARK_USED(comm)
620 : ! only defined in parallel
621 : CPABORT("not in parallel mode")
622 : #endif
623 1070 : CALL mp_timestop(handle)
624 1070 : END SUBROUTINE mp_send_${nametype1}$
625 :
626 : ! **************************************************************************************************
627 : !> \brief Send rank-1 data to another process
628 : !> \param[in] msg Rank-1 data to send
629 : !> \param dest ...
630 : !> \param tag ...
631 : !> \param comm ...
632 : !> \note see mp_send_${nametype1}$
633 : ! **************************************************************************************************
634 118425 : SUBROUTINE mp_send_${nametype1}$v(msg, dest, tag, comm)
635 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:)
636 : INTEGER, INTENT(IN) :: dest, tag
637 : CLASS(mp_comm_type), INTENT(IN) :: comm
638 :
639 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_send_${nametype1}$v'
640 :
641 : INTEGER :: handle
642 : #if defined(__parallel)
643 : INTEGER :: ierr, msglen
644 : #endif
645 :
646 118425 : CALL mp_timeset(routineN, handle)
647 :
648 : #if defined(__parallel)
649 118425 : msglen = SIZE(msg)
650 118425 : CALL mpi_send(msg, msglen, ${mpi_type1}$, dest, tag, comm%handle, ierr)
651 118425 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routineN)
652 118425 : CALL add_perf(perf_id=13, count=1, msg_size=msglen*${bytes1}$)
653 : #else
654 : MARK_USED(msg)
655 : MARK_USED(dest)
656 : MARK_USED(tag)
657 : MARK_USED(comm)
658 : ! only defined in parallel
659 : CPABORT("not in parallel mode")
660 : #endif
661 118425 : CALL mp_timestop(handle)
662 118425 : END SUBROUTINE mp_send_${nametype1}$v
663 :
664 : ! **************************************************************************************************
665 : !> \brief Send rank-2 data to another process
666 : !> \param[in] msg Rank-2 data to send
667 : !> \param dest ...
668 : !> \param tag ...
669 : !> \param comm ...
670 : !> \note see mp_send_${nametype1}$
671 : ! **************************************************************************************************
672 4 : SUBROUTINE mp_send_${nametype1}$m2(msg, dest, tag, comm)
673 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:, :)
674 : INTEGER, INTENT(IN) :: dest, tag
675 : CLASS(mp_comm_type), INTENT(IN) :: comm
676 :
677 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_send_${nametype1}$m2'
678 :
679 : INTEGER :: handle
680 : #if defined(__parallel)
681 : INTEGER :: ierr, msglen
682 : #endif
683 :
684 4 : CALL mp_timeset(routineN, handle)
685 :
686 : #if defined(__parallel)
687 12 : msglen = SIZE(msg)
688 4 : CALL mpi_send(msg, msglen, ${mpi_type1}$, dest, tag, comm%handle, ierr)
689 4 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routineN)
690 4 : CALL add_perf(perf_id=13, count=1, msg_size=msglen*${bytes1}$)
691 : #else
692 : MARK_USED(msg)
693 : MARK_USED(dest)
694 : MARK_USED(tag)
695 : MARK_USED(comm)
696 : ! only defined in parallel
697 : CPABORT("not in parallel mode")
698 : #endif
699 4 : CALL mp_timestop(handle)
700 4 : END SUBROUTINE mp_send_${nametype1}$m2
701 :
702 : ! **************************************************************************************************
703 : !> \brief Send rank-3 data to another process
704 : !> \param[in] msg Rank-3 data to send
705 : !> \param dest ...
706 : !> \param tag ...
707 : !> \param comm ...
708 : !> \note see mp_send_${nametype1}$
709 : ! **************************************************************************************************
710 258 : SUBROUTINE mp_send_${nametype1}$m3(msg, dest, tag, comm)
711 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:, :, :)
712 : INTEGER, INTENT(IN) :: dest, tag
713 : CLASS(mp_comm_type), INTENT(IN) :: comm
714 :
715 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_send_${nametype1}m3'
716 :
717 : INTEGER :: handle
718 : #if defined(__parallel)
719 : INTEGER :: ierr, msglen
720 : #endif
721 :
722 258 : CALL mp_timeset(routineN, handle)
723 :
724 : #if defined(__parallel)
725 1032 : msglen = SIZE(msg)
726 258 : CALL mpi_send(msg, msglen, ${mpi_type1}$, dest, tag, comm%handle, ierr)
727 258 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_send @ "//routineN)
728 258 : CALL add_perf(perf_id=13, count=1, msg_size=msglen*${bytes1}$)
729 : #else
730 : MARK_USED(msg)
731 : MARK_USED(dest)
732 : MARK_USED(tag)
733 : MARK_USED(comm)
734 : ! only defined in parallel
735 : CPABORT("not in parallel mode")
736 : #endif
737 258 : CALL mp_timestop(handle)
738 258 : END SUBROUTINE mp_send_${nametype1}$m3
739 :
740 : ! **************************************************************************************************
741 : !> \brief Receive one datum from another process
742 : !> \param[in,out] msg Place received data into this variable
743 : !> \param[in,out] source Process to receive from
744 : !> \param[in,out] tag Transfer identifier
745 : !> \param[in] comm Message passing environment identifier
746 : !> \par MPI mapping
747 : !> mpi_send
748 : ! **************************************************************************************************
749 1070 : SUBROUTINE mp_recv_${nametype1}$ (msg, source, tag, comm)
750 : ${type1}$, INTENT(INOUT) :: msg
751 : INTEGER, INTENT(INOUT) :: source, tag
752 : CLASS(mp_comm_type), INTENT(IN) :: comm
753 :
754 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_recv_${nametype1}$'
755 :
756 : INTEGER :: handle
757 : #if defined(__parallel)
758 : INTEGER :: ierr, msglen
759 : MPI_STATUS_TYPE :: status
760 : #endif
761 :
762 1070 : CALL mp_timeset(routineN, handle)
763 :
764 : #if defined(__parallel)
765 1070 : msglen = 1
766 1070 : IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
767 1005 : CALL mpi_recv(msg, msglen, ${mpi_type1}$, source, tag, comm%handle, MPI_STATUS_IGNORE, ierr)
768 1005 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routineN)
769 : ELSE
770 65 : CALL mpi_recv(msg, msglen, ${mpi_type1}$, source, tag, comm%handle, status, ierr)
771 65 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routineN)
772 65 : CALL add_perf(perf_id=14, count=1, msg_size=msglen*${bytes1}$)
773 65 : source = status MPI_STATUS_EXTRACT(MPI_SOURCE)
774 65 : tag = status MPI_STATUS_EXTRACT(MPI_TAG)
775 : END IF
776 : #else
777 : MARK_USED(msg)
778 : MARK_USED(source)
779 : MARK_USED(tag)
780 : MARK_USED(comm)
781 : ! only defined in parallel
782 : CPABORT("not in parallel mode")
783 : #endif
784 1070 : CALL mp_timestop(handle)
785 1070 : END SUBROUTINE mp_recv_${nametype1}$
786 :
787 : ! **************************************************************************************************
788 : !> \brief Receive rank-1 data from another process
789 : !> \param[in,out] msg Place received data into this rank-1 array
790 : !> \param source ...
791 : !> \param tag ...
792 : !> \param comm ...
793 : !> \note see mp_recv_${nametype1}$
794 : ! **************************************************************************************************
795 118405 : SUBROUTINE mp_recv_${nametype1}$v(msg, source, tag, comm)
796 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:)
797 : INTEGER, INTENT(INOUT) :: source, tag
798 : CLASS(mp_comm_type), INTENT(IN) :: comm
799 :
800 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_recv_${nametype1}$v'
801 :
802 : INTEGER :: handle
803 : #if defined(__parallel)
804 : INTEGER :: ierr, msglen
805 : MPI_STATUS_TYPE :: status
806 : #endif
807 :
808 118405 : CALL mp_timeset(routineN, handle)
809 :
810 : #if defined(__parallel)
811 118405 : msglen = SIZE(msg)
812 118405 : IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
813 109531 : CALL mpi_recv(msg, msglen, ${mpi_type1}$, source, tag, comm%handle, MPI_STATUS_IGNORE, ierr)
814 109531 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routineN)
815 : ELSE
816 8874 : CALL mpi_recv(msg, msglen, ${mpi_type1}$, source, tag, comm%handle, status, ierr)
817 8874 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routineN)
818 8874 : CALL add_perf(perf_id=14, count=1, msg_size=msglen*${bytes1}$)
819 8874 : source = status MPI_STATUS_EXTRACT(MPI_SOURCE)
820 8874 : tag = status MPI_STATUS_EXTRACT(MPI_TAG)
821 : END IF
822 : #else
823 : MARK_USED(msg)
824 : MARK_USED(source)
825 : MARK_USED(tag)
826 : MARK_USED(comm)
827 : ! only defined in parallel
828 : CPABORT("not in parallel mode")
829 : #endif
830 118405 : CALL mp_timestop(handle)
831 118405 : END SUBROUTINE mp_recv_${nametype1}$v
832 :
833 : ! **************************************************************************************************
834 : !> \brief Receive rank-2 data from another process
835 : !> \param[in,out] msg Place received data into this rank-2 array
836 : !> \param source ...
837 : !> \param tag ...
838 : !> \param comm ...
839 : !> \note see mp_recv_${nametype1}$
840 : ! **************************************************************************************************
841 4 : SUBROUTINE mp_recv_${nametype1}$m2(msg, source, tag, comm)
842 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
843 : INTEGER, INTENT(INOUT) :: source, tag
844 : CLASS(mp_comm_type), INTENT(IN) :: comm
845 :
846 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_recv_${nametype1}$m2'
847 :
848 : INTEGER :: handle
849 : #if defined(__parallel)
850 : INTEGER :: ierr, msglen
851 : MPI_STATUS_TYPE :: status
852 : #endif
853 :
854 4 : CALL mp_timeset(routineN, handle)
855 :
856 : #if defined(__parallel)
857 12 : msglen = SIZE(msg)
858 4 : IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
859 4 : CALL mpi_recv(msg, msglen, ${mpi_type1}$, source, tag, comm%handle, MPI_STATUS_IGNORE, ierr)
860 4 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routineN)
861 : ELSE
862 0 : CALL mpi_recv(msg, msglen, ${mpi_type1}$, source, tag, comm%handle, status, ierr)
863 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routineN)
864 0 : CALL add_perf(perf_id=14, count=1, msg_size=msglen*${bytes1}$)
865 0 : source = status MPI_STATUS_EXTRACT(MPI_SOURCE)
866 0 : tag = status MPI_STATUS_EXTRACT(MPI_TAG)
867 : END IF
868 : #else
869 : MARK_USED(msg)
870 : MARK_USED(source)
871 : MARK_USED(tag)
872 : MARK_USED(comm)
873 : ! only defined in parallel
874 : CPABORT("not in parallel mode")
875 : #endif
876 4 : CALL mp_timestop(handle)
877 4 : END SUBROUTINE mp_recv_${nametype1}$m2
878 :
879 : ! **************************************************************************************************
880 : !> \brief Receive rank-3 data from another process
881 : !> \param[in,out] msg Place received data into this rank-3 array
882 : !> \param source ...
883 : !> \param tag ...
884 : !> \param comm ...
885 : !> \note see mp_recv_${nametype1}$
886 : ! **************************************************************************************************
887 258 : SUBROUTINE mp_recv_${nametype1}$m3(msg, source, tag, comm)
888 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :)
889 : INTEGER, INTENT(INOUT) :: source, tag
890 : CLASS(mp_comm_type), INTENT(IN) :: comm
891 :
892 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_recv_${nametype1}$m3'
893 :
894 : INTEGER :: handle
895 : #if defined(__parallel)
896 : INTEGER :: ierr, msglen
897 : MPI_STATUS_TYPE :: status
898 : #endif
899 :
900 258 : CALL mp_timeset(routineN, handle)
901 :
902 : #if defined(__parallel)
903 1032 : msglen = SIZE(msg)
904 258 : IF (source /= mp_any_source .AND. tag /= mp_any_tag) THEN
905 258 : CALL mpi_recv(msg, msglen, ${mpi_type1}$, source, tag, comm%handle, MPI_STATUS_IGNORE, ierr)
906 258 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routineN)
907 : ELSE
908 0 : CALL mpi_recv(msg, msglen, ${mpi_type1}$, source, tag, comm%handle, status, ierr)
909 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_recv @ "//routineN)
910 0 : CALL add_perf(perf_id=14, count=1, msg_size=msglen*${bytes1}$)
911 0 : source = status MPI_STATUS_EXTRACT(MPI_SOURCE)
912 0 : tag = status MPI_STATUS_EXTRACT(MPI_TAG)
913 : END IF
914 : #else
915 : MARK_USED(msg)
916 : MARK_USED(source)
917 : MARK_USED(tag)
918 : MARK_USED(comm)
919 : ! only defined in parallel
920 : CPABORT("not in parallel mode")
921 : #endif
922 258 : CALL mp_timestop(handle)
923 258 : END SUBROUTINE mp_recv_${nametype1}$m3
924 :
925 : ! **************************************************************************************************
926 : !> \brief Broadcasts a datum to all processes.
927 : !> \param[in] msg Datum to broadcast
928 : !> \param[in] source Processes which broadcasts
929 : !> \param[in] comm Message passing environment identifier
930 : !> \par MPI mapping
931 : !> mpi_bcast
932 : ! **************************************************************************************************
933 763418 : SUBROUTINE mp_bcast_${nametype1}$ (msg, source, comm)
934 : ${type1}$, INTENT(INOUT) :: msg
935 : INTEGER, INTENT(IN) :: source
936 : CLASS(mp_comm_type), INTENT(IN) :: comm
937 :
938 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_${nametype1}$'
939 :
940 : INTEGER :: handle
941 : #if defined(__parallel)
942 : INTEGER :: ierr, msglen
943 : #endif
944 :
945 763418 : CALL mp_timeset(routineN, handle)
946 :
947 : #if defined(__parallel)
948 763418 : msglen = 1
949 763418 : CALL mpi_bcast(msg, msglen, ${mpi_type1}$, source, comm%handle, ierr)
950 763418 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
951 763418 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*${bytes1}$)
952 : #else
953 : MARK_USED(msg)
954 : MARK_USED(source)
955 : MARK_USED(comm)
956 : #endif
957 763418 : CALL mp_timestop(handle)
958 763418 : END SUBROUTINE mp_bcast_${nametype1}$
959 :
960 : ! **************************************************************************************************
961 : !> \brief Broadcasts a datum to all processes. Convenience function using the source of the communicator
962 : !> \param[in] msg Datum to broadcast
963 : !> \param[in] comm Message passing environment identifier
964 : !> \par MPI mapping
965 : !> mpi_bcast
966 : ! **************************************************************************************************
967 337849 : SUBROUTINE mp_bcast_${nametype1}$_src(msg, comm)
968 : ${type1}$, INTENT(INOUT) :: msg
969 : CLASS(mp_comm_type), INTENT(IN) :: comm
970 :
971 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_${nametype1}$_src'
972 :
973 : INTEGER :: handle
974 : #if defined(__parallel)
975 : INTEGER :: ierr, msglen
976 : #endif
977 :
978 337849 : CALL mp_timeset(routineN, handle)
979 :
980 : #if defined(__parallel)
981 337849 : msglen = 1
982 337849 : CALL mpi_bcast(msg, msglen, ${mpi_type1}$, comm%source, comm%handle, ierr)
983 337849 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
984 337849 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*${bytes1}$)
985 : #else
986 : MARK_USED(msg)
987 : MARK_USED(comm)
988 : #endif
989 337849 : CALL mp_timestop(handle)
990 337849 : END SUBROUTINE mp_bcast_${nametype1}$_src
991 :
992 : ! **************************************************************************************************
993 : !> \brief Broadcasts a datum to all processes.
994 : !> \param[in] msg Datum to broadcast
995 : !> \param[in] source Processes which broadcasts
996 : !> \param[in] comm Message passing environment identifier
997 : !> \par MPI mapping
998 : !> mpi_bcast
999 : ! **************************************************************************************************
1000 0 : SUBROUTINE mp_ibcast_${nametype1}$ (msg, source, comm, request)
1001 : ${type1}$, INTENT(INOUT) :: msg
1002 : INTEGER, INTENT(IN) :: source
1003 : CLASS(mp_comm_type), INTENT(IN) :: comm
1004 : TYPE(mp_request_type), INTENT(OUT) :: request
1005 :
1006 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_ibcast_${nametype1}$'
1007 :
1008 : INTEGER :: handle
1009 : #if defined(__parallel)
1010 : INTEGER :: ierr, msglen
1011 : #endif
1012 :
1013 0 : CALL mp_timeset(routineN, handle)
1014 :
1015 : #if defined(__parallel)
1016 0 : msglen = 1
1017 0 : CALL mpi_ibcast(msg, msglen, ${mpi_type1}$, source, comm%handle, request%handle, ierr)
1018 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routineN)
1019 0 : CALL add_perf(perf_id=22, count=1, msg_size=msglen*${bytes1}$)
1020 : #else
1021 : MARK_USED(msg)
1022 : MARK_USED(source)
1023 : MARK_USED(comm)
1024 : request = mp_request_null
1025 : #endif
1026 0 : CALL mp_timestop(handle)
1027 0 : END SUBROUTINE mp_ibcast_${nametype1}$
1028 :
1029 : ! **************************************************************************************************
1030 : !> \brief Broadcasts rank-1 data to all processes
1031 : !> \param[in] msg Data to broadcast
1032 : !> \param source ...
1033 : !> \param comm ...
1034 : !> \note see mp_bcast_${nametype1}$1
1035 : ! **************************************************************************************************
1036 1832550 : SUBROUTINE mp_bcast_${nametype1}$v(msg, source, comm)
1037 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:)
1038 : INTEGER, INTENT(IN) :: source
1039 : CLASS(mp_comm_type), INTENT(IN) :: comm
1040 :
1041 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_${nametype1}$v'
1042 :
1043 : INTEGER :: handle
1044 : #if defined(__parallel)
1045 : INTEGER :: ierr, msglen
1046 : #endif
1047 :
1048 1832550 : CALL mp_timeset(routineN, handle)
1049 :
1050 : #if defined(__parallel)
1051 1832550 : msglen = SIZE(msg)
1052 1832550 : CALL mpi_bcast(msg, msglen, ${mpi_type1}$, source, comm%handle, ierr)
1053 1832550 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
1054 1832550 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*${bytes1}$)
1055 : #else
1056 : MARK_USED(msg)
1057 : MARK_USED(source)
1058 : MARK_USED(comm)
1059 : #endif
1060 1832550 : CALL mp_timestop(handle)
1061 1832550 : END SUBROUTINE mp_bcast_${nametype1}$v
1062 :
1063 : ! **************************************************************************************************
1064 : !> \brief Broadcasts rank-1 data to all processes, uses the source of the communicator, convenience function
1065 : !> \param[in] msg Data to broadcast
1066 : !> \param comm ...
1067 : !> \note see mp_bcast_${nametype1}$1
1068 : ! **************************************************************************************************
1069 89910 : SUBROUTINE mp_bcast_${nametype1}$v_src(msg, comm)
1070 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:)
1071 : CLASS(mp_comm_type), INTENT(IN) :: comm
1072 :
1073 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_${nametype1}$v_src'
1074 :
1075 : INTEGER :: handle
1076 : #if defined(__parallel)
1077 : INTEGER :: ierr, msglen
1078 : #endif
1079 :
1080 89910 : CALL mp_timeset(routineN, handle)
1081 :
1082 : #if defined(__parallel)
1083 89910 : msglen = SIZE(msg)
1084 89910 : CALL mpi_bcast(msg, msglen, ${mpi_type1}$, comm%source, comm%handle, ierr)
1085 89910 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
1086 89910 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*${bytes1}$)
1087 : #else
1088 : MARK_USED(msg)
1089 : MARK_USED(comm)
1090 : #endif
1091 89910 : CALL mp_timestop(handle)
1092 89910 : END SUBROUTINE mp_bcast_${nametype1}$v_src
1093 :
1094 : ! **************************************************************************************************
1095 : !> \brief Broadcasts rank-1 data to all processes
1096 : !> \param[in] msg Data to broadcast
1097 : !> \param source ...
1098 : !> \param comm ...
1099 : !> \note see mp_bcast_${nametype1}$1
1100 : ! **************************************************************************************************
1101 0 : SUBROUTINE mp_ibcast_${nametype1}$v(msg, source, comm, request)
1102 : ${type1}$, INTENT(INOUT) :: msg(:)
1103 : INTEGER, INTENT(IN) :: source
1104 : CLASS(mp_comm_type), INTENT(IN) :: comm
1105 : TYPE(mp_request_type) :: request
1106 :
1107 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_ibcast_${nametype1}$v'
1108 :
1109 : INTEGER :: handle
1110 : #if defined(__parallel)
1111 : INTEGER :: ierr, msglen
1112 : #endif
1113 :
1114 0 : CALL mp_timeset(routineN, handle)
1115 :
1116 : #if defined(__parallel)
1117 : #if !defined(__GNUC__) || __GNUC__ >= 9
1118 0 : CPASSERT(IS_CONTIGUOUS(msg) .OR. SIZE(msg) == 0)
1119 : #endif
1120 0 : msglen = SIZE(msg)
1121 0 : CALL mpi_ibcast(msg, msglen, ${mpi_type1}$, source, comm%handle, request%handle, ierr)
1122 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibcast @ "//routineN)
1123 0 : CALL add_perf(perf_id=22, count=1, msg_size=msglen*${bytes1}$)
1124 : #else
1125 : MARK_USED(msg)
1126 : MARK_USED(source)
1127 : MARK_USED(comm)
1128 : request = mp_request_null
1129 : #endif
1130 0 : CALL mp_timestop(handle)
1131 0 : END SUBROUTINE mp_ibcast_${nametype1}$v
1132 :
1133 : ! **************************************************************************************************
1134 : !> \brief Broadcasts rank-2 data to all processes
1135 : !> \param[in] msg Data to broadcast
1136 : !> \param source ...
1137 : !> \param comm ...
1138 : !> \note see mp_bcast_${nametype1}$1
1139 : ! **************************************************************************************************
1140 713133 : SUBROUTINE mp_bcast_${nametype1}$m(msg, source, comm)
1141 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
1142 : INTEGER, INTENT(IN) :: source
1143 : CLASS(mp_comm_type), INTENT(IN) :: comm
1144 :
1145 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_${nametype1}$m'
1146 :
1147 : INTEGER :: handle
1148 : #if defined(__parallel)
1149 : INTEGER :: ierr, msglen
1150 : #endif
1151 :
1152 713133 : CALL mp_timeset(routineN, handle)
1153 :
1154 : #if defined(__parallel)
1155 2139399 : msglen = SIZE(msg)
1156 713133 : CALL mpi_bcast(msg, msglen, ${mpi_type1}$, source, comm%handle, ierr)
1157 713133 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
1158 713133 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*${bytes1}$)
1159 : #else
1160 : MARK_USED(msg)
1161 : MARK_USED(source)
1162 : MARK_USED(comm)
1163 : #endif
1164 713133 : CALL mp_timestop(handle)
1165 713133 : END SUBROUTINE mp_bcast_${nametype1}$m
1166 :
1167 : ! **************************************************************************************************
1168 : !> \brief Broadcasts rank-2 data to all processes
1169 : !> \param[in] msg Data to broadcast
1170 : !> \param source ...
1171 : !> \param comm ...
1172 : !> \note see mp_bcast_${nametype1}$1
1173 : ! **************************************************************************************************
1174 9421 : SUBROUTINE mp_bcast_${nametype1}$m_src(msg, comm)
1175 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
1176 : CLASS(mp_comm_type), INTENT(IN) :: comm
1177 :
1178 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_${nametype1}$m_src'
1179 :
1180 : INTEGER :: handle
1181 : #if defined(__parallel)
1182 : INTEGER :: ierr, msglen
1183 : #endif
1184 :
1185 9421 : CALL mp_timeset(routineN, handle)
1186 :
1187 : #if defined(__parallel)
1188 28263 : msglen = SIZE(msg)
1189 9421 : CALL mpi_bcast(msg, msglen, ${mpi_type1}$, comm%source, comm%handle, ierr)
1190 9421 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
1191 9421 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*${bytes1}$)
1192 : #else
1193 : MARK_USED(msg)
1194 : MARK_USED(comm)
1195 : #endif
1196 9421 : CALL mp_timestop(handle)
1197 9421 : END SUBROUTINE mp_bcast_${nametype1}$m_src
1198 :
1199 : ! **************************************************************************************************
1200 : !> \brief Broadcasts rank-3 data to all processes
1201 : !> \param[in] msg Data to broadcast
1202 : !> \param source ...
1203 : !> \param comm ...
1204 : !> \note see mp_bcast_${nametype1}$1
1205 : ! **************************************************************************************************
1206 1316 : SUBROUTINE mp_bcast_${nametype1}$3(msg, source, comm)
1207 : ${type1}$, CONTIGUOUS :: msg(:, :, :)
1208 : INTEGER, INTENT(IN) :: source
1209 : CLASS(mp_comm_type), INTENT(IN) :: comm
1210 :
1211 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_${nametype1}$3'
1212 :
1213 : INTEGER :: handle
1214 : #if defined(__parallel)
1215 : INTEGER :: ierr, msglen
1216 : #endif
1217 :
1218 1316 : CALL mp_timeset(routineN, handle)
1219 :
1220 : #if defined(__parallel)
1221 5264 : msglen = SIZE(msg)
1222 1316 : CALL mpi_bcast(msg, msglen, ${mpi_type1}$, source, comm%handle, ierr)
1223 1316 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
1224 1316 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*${bytes1}$)
1225 : #else
1226 : MARK_USED(msg)
1227 : MARK_USED(source)
1228 : MARK_USED(comm)
1229 : #endif
1230 1316 : CALL mp_timestop(handle)
1231 1316 : END SUBROUTINE mp_bcast_${nametype1}$3
1232 :
1233 : ! **************************************************************************************************
1234 : !> \brief Broadcasts rank-3 data to all processes. Uses the source of the communicator for convenience
1235 : !> \param[in] msg Data to broadcast
1236 : !> \param source ...
1237 : !> \param comm ...
1238 : !> \note see mp_bcast_${nametype1}$1
1239 : ! **************************************************************************************************
1240 92 : SUBROUTINE mp_bcast_${nametype1}$3_src(msg, comm)
1241 : ${type1}$, CONTIGUOUS :: msg(:, :, :)
1242 : CLASS(mp_comm_type), INTENT(IN) :: comm
1243 :
1244 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_${nametype1}$3_src'
1245 :
1246 : INTEGER :: handle
1247 : #if defined(__parallel)
1248 : INTEGER :: ierr, msglen
1249 : #endif
1250 :
1251 92 : CALL mp_timeset(routineN, handle)
1252 :
1253 : #if defined(__parallel)
1254 368 : msglen = SIZE(msg)
1255 92 : CALL mpi_bcast(msg, msglen, ${mpi_type1}$, comm%source, comm%handle, ierr)
1256 92 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
1257 92 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*${bytes1}$)
1258 : #else
1259 : MARK_USED(msg)
1260 : MARK_USED(comm)
1261 : #endif
1262 92 : CALL mp_timestop(handle)
1263 92 : END SUBROUTINE mp_bcast_${nametype1}$3_src
1264 :
1265 : ! **************************************************************************************************
1266 : !> \brief Sums a datum from all processes with result left on all processes.
1267 : !> \param[in,out] msg Datum to sum (input) and result (output)
1268 : !> \param[in] comm Message passing environment identifier
1269 : !> \par MPI mapping
1270 : !> mpi_allreduce
1271 : ! **************************************************************************************************
1272 26516065 : SUBROUTINE mp_sum_${nametype1}$ (msg, comm)
1273 : ${type1}$, INTENT(INOUT) :: msg
1274 : CLASS(mp_comm_type), INTENT(IN) :: comm
1275 :
1276 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_${nametype1}$'
1277 :
1278 : INTEGER :: handle
1279 : #if defined(__parallel)
1280 : INTEGER :: ierr, msglen
1281 : #endif
1282 :
1283 26516065 : CALL mp_timeset(routineN, handle)
1284 :
1285 : #if defined(__parallel)
1286 26516065 : msglen = 1
1287 26516065 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_SUM, comm%handle, ierr)
1288 26516065 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1289 26516065 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1290 : #else
1291 : MARK_USED(msg)
1292 : MARK_USED(comm)
1293 : #endif
1294 26516065 : CALL mp_timestop(handle)
1295 26516065 : END SUBROUTINE mp_sum_${nametype1}$
1296 :
1297 : ! **************************************************************************************************
1298 : !> \brief Element-wise sum of a rank-1 array on all processes.
1299 : !> \param[in,out] msg Vector to sum and result
1300 : !> \param comm ...
1301 : !> \note see mp_sum_${nametype1}$
1302 : ! **************************************************************************************************
1303 4802622 : SUBROUTINE mp_sum_${nametype1}$v(msg, comm)
1304 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:)
1305 : CLASS(mp_comm_type), INTENT(IN) :: comm
1306 :
1307 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_${nametype1}$v'
1308 :
1309 : INTEGER :: handle
1310 : #if defined(__parallel)
1311 : INTEGER :: ierr, msglen
1312 : #endif
1313 :
1314 4802622 : CALL mp_timeset(routineN, handle)
1315 :
1316 : #if defined(__parallel)
1317 4802622 : msglen = SIZE(msg)
1318 4802622 : IF (msglen > 0) THEN
1319 4656688 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_SUM, comm%handle, ierr)
1320 4656688 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1321 : END IF
1322 4802622 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1323 : #else
1324 : MARK_USED(msg)
1325 : MARK_USED(comm)
1326 : #endif
1327 4802622 : CALL mp_timestop(handle)
1328 4802622 : END SUBROUTINE mp_sum_${nametype1}$v
1329 :
1330 : ! **************************************************************************************************
1331 : !> \brief Element-wise sum of a rank-1 array on all processes.
1332 : !> \param[in,out] msg Vector to sum and result
1333 : !> \param comm ...
1334 : !> \note see mp_sum_${nametype1}$
1335 : ! **************************************************************************************************
1336 0 : SUBROUTINE mp_isum_${nametype1}$v(msg, comm, request)
1337 : ${type1}$, INTENT(INOUT) :: msg(:)
1338 : CLASS(mp_comm_type), INTENT(IN) :: comm
1339 : TYPE(mp_request_type), INTENT(OUT) :: request
1340 :
1341 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isum_${nametype1}$v'
1342 :
1343 : INTEGER :: handle
1344 : #if defined(__parallel)
1345 : INTEGER :: ierr, msglen
1346 : #endif
1347 :
1348 0 : CALL mp_timeset(routineN, handle)
1349 :
1350 : #if defined(__parallel)
1351 : #if !defined(__GNUC__) || __GNUC__ >= 9
1352 0 : CPASSERT(IS_CONTIGUOUS(msg) .OR. SIZE(msg) == 0)
1353 : #endif
1354 0 : msglen = SIZE(msg)
1355 0 : IF (msglen > 0) THEN
1356 0 : CALL mpi_iallreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_SUM, comm%handle, request%handle, ierr)
1357 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallreduce @ "//routineN)
1358 : ELSE
1359 0 : request = mp_request_null
1360 : END IF
1361 0 : CALL add_perf(perf_id=23, count=1, msg_size=msglen*${bytes1}$)
1362 : #else
1363 : MARK_USED(msg)
1364 : MARK_USED(comm)
1365 : request = mp_request_null
1366 : #endif
1367 0 : CALL mp_timestop(handle)
1368 0 : END SUBROUTINE mp_isum_${nametype1}$v
1369 :
1370 : ! **************************************************************************************************
1371 : !> \brief Element-wise sum of a rank-2 array on all processes.
1372 : !> \param[in] msg Matrix to sum and result
1373 : !> \param comm ...
1374 : !> \note see mp_sum_${nametype1}$
1375 : ! **************************************************************************************************
1376 2050003 : SUBROUTINE mp_sum_${nametype1}$m(msg, comm)
1377 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
1378 : CLASS(mp_comm_type), INTENT(IN) :: comm
1379 :
1380 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_${nametype1}$m'
1381 :
1382 : INTEGER :: handle
1383 : #if defined(__parallel)
1384 : INTEGER, PARAMETER :: max_msg = 2**25
1385 : INTEGER :: ierr, m1, msglen, step, msglensum
1386 : #endif
1387 :
1388 2050003 : CALL mp_timeset(routineN, handle)
1389 :
1390 : #if defined(__parallel)
1391 : ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
1392 6150009 : step = MAX(1, SIZE(msg, 2)/MAX(1, SIZE(msg)/max_msg))
1393 2050003 : msglensum = 0
1394 6149909 : DO m1 = LBOUND(msg, 2), UBOUND(msg, 2), step
1395 2049953 : msglen = SIZE(msg, 1)*(MIN(UBOUND(msg, 2), m1 + step - 1) - m1 + 1)
1396 2049953 : msglensum = msglensum + msglen
1397 4099956 : IF (msglen > 0) THEN
1398 2048781 : CALL mpi_allreduce(MPI_IN_PLACE, msg(LBOUND(msg, 1), m1), msglen, ${mpi_type1}$, MPI_SUM, comm%handle, ierr)
1399 2048781 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1400 : END IF
1401 : END DO
1402 2050003 : CALL add_perf(perf_id=3, count=1, msg_size=msglensum*${bytes1}$)
1403 : #else
1404 : MARK_USED(msg)
1405 : MARK_USED(comm)
1406 : #endif
1407 2050003 : CALL mp_timestop(handle)
1408 2050003 : END SUBROUTINE mp_sum_${nametype1}$m
1409 :
1410 : ! **************************************************************************************************
1411 : !> \brief Element-wise sum of a rank-3 array on all processes.
1412 : !> \param[in] msg Array to sum and result
1413 : !> \param comm ...
1414 : !> \note see mp_sum_${nametype1}$
1415 : ! **************************************************************************************************
1416 65103 : SUBROUTINE mp_sum_${nametype1}$m3(msg, comm)
1417 : ${type1}$, INTENT(INOUT), CONTIGUOUS :: msg(:, :, :)
1418 : CLASS(mp_comm_type), INTENT(IN) :: comm
1419 :
1420 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_${nametype1}$m3'
1421 :
1422 : INTEGER :: handle
1423 : #if defined(__parallel)
1424 : INTEGER :: ierr, msglen
1425 : #endif
1426 :
1427 65103 : CALL mp_timeset(routineN, handle)
1428 :
1429 : #if defined(__parallel)
1430 260412 : msglen = SIZE(msg)
1431 65103 : IF (msglen > 0) THEN
1432 65103 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_SUM, comm%handle, ierr)
1433 65103 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1434 : END IF
1435 65103 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1436 : #else
1437 : MARK_USED(msg)
1438 : MARK_USED(comm)
1439 : #endif
1440 65103 : CALL mp_timestop(handle)
1441 65103 : END SUBROUTINE mp_sum_${nametype1}$m3
1442 :
1443 : ! **************************************************************************************************
1444 : !> \brief Element-wise sum of a rank-4 array on all processes.
1445 : !> \param[in] msg Array to sum and result
1446 : !> \param comm ...
1447 : !> \note see mp_sum_${nametype1}$
1448 : ! **************************************************************************************************
1449 252 : SUBROUTINE mp_sum_${nametype1}$m4(msg, comm)
1450 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :, :, :)
1451 : CLASS(mp_comm_type), INTENT(IN) :: comm
1452 :
1453 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_${nametype1}$m4'
1454 :
1455 : INTEGER :: handle
1456 : #if defined(__parallel)
1457 : INTEGER :: ierr, msglen
1458 : #endif
1459 :
1460 252 : CALL mp_timeset(routineN, handle)
1461 :
1462 : #if defined(__parallel)
1463 1260 : msglen = SIZE(msg)
1464 252 : IF (msglen > 0) THEN
1465 252 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_SUM, comm%handle, ierr)
1466 252 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1467 : END IF
1468 252 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1469 : #else
1470 : MARK_USED(msg)
1471 : MARK_USED(comm)
1472 : #endif
1473 252 : CALL mp_timestop(handle)
1474 252 : END SUBROUTINE mp_sum_${nametype1}$m4
1475 :
1476 : ! **************************************************************************************************
1477 : !> \brief Element-wise sum of data from all processes with result left only on
1478 : !> one.
1479 : !> \param[in,out] msg Vector to sum (input) and (only on process root)
1480 : !> result (output)
1481 : !> \param root ...
1482 : !> \param[in] comm Message passing environment identifier
1483 : !> \par MPI mapping
1484 : !> mpi_reduce
1485 : ! **************************************************************************************************
1486 54 : SUBROUTINE mp_sum_root_${nametype1}$v(msg, root, comm)
1487 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:)
1488 : INTEGER, INTENT(IN) :: root
1489 : CLASS(mp_comm_type), INTENT(IN) :: comm
1490 :
1491 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_root_${nametype1}$v'
1492 :
1493 : INTEGER :: handle
1494 : #if defined(__parallel)
1495 : INTEGER :: ierr, m1, msglen, taskid
1496 54 : ${type1}$, ALLOCATABLE :: res(:)
1497 : #endif
1498 :
1499 54 : CALL mp_timeset(routineN, handle)
1500 :
1501 : #if defined(__parallel)
1502 54 : msglen = SIZE(msg)
1503 54 : CALL mpi_comm_rank(comm%handle, taskid, ierr)
1504 54 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routineN)
1505 54 : IF (msglen > 0) THEN
1506 54 : m1 = SIZE(msg, 1)
1507 162 : ALLOCATE (res(m1))
1508 : CALL mpi_reduce(msg, res, msglen, ${mpi_type1}$, MPI_SUM, &
1509 54 : root, comm%handle, ierr)
1510 54 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routineN)
1511 54 : IF (taskid == root) THEN
1512 135 : msg = res
1513 : END IF
1514 54 : DEALLOCATE (res)
1515 : END IF
1516 54 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1517 : #else
1518 : MARK_USED(msg)
1519 : MARK_USED(root)
1520 : MARK_USED(comm)
1521 : #endif
1522 54 : CALL mp_timestop(handle)
1523 54 : END SUBROUTINE mp_sum_root_${nametype1}$v
1524 :
1525 : ! **************************************************************************************************
1526 : !> \brief Element-wise sum of data from all processes with result left only on
1527 : !> one.
1528 : !> \param[in,out] msg Matrix to sum (input) and (only on process root)
1529 : !> result (output)
1530 : !> \param root ...
1531 : !> \param comm ...
1532 : !> \note see mp_sum_root_${nametype1}$v
1533 : ! **************************************************************************************************
1534 0 : SUBROUTINE mp_sum_root_${nametype1}$m(msg, root, comm)
1535 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
1536 : INTEGER, INTENT(IN) :: root
1537 : CLASS(mp_comm_type), INTENT(IN) :: comm
1538 :
1539 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_root_rm'
1540 :
1541 : INTEGER :: handle
1542 : #if defined(__parallel)
1543 : INTEGER :: ierr, m1, m2, msglen, taskid
1544 0 : ${type1}$, ALLOCATABLE :: res(:, :)
1545 : #endif
1546 :
1547 0 : CALL mp_timeset(routineN, handle)
1548 :
1549 : #if defined(__parallel)
1550 0 : msglen = SIZE(msg)
1551 0 : CALL mpi_comm_rank(comm%handle, taskid, ierr)
1552 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routineN)
1553 0 : IF (msglen > 0) THEN
1554 0 : m1 = SIZE(msg, 1)
1555 0 : m2 = SIZE(msg, 2)
1556 0 : ALLOCATE (res(m1, m2))
1557 0 : CALL mpi_reduce(msg, res, msglen, ${mpi_type1}$, MPI_SUM, root, comm%handle, ierr)
1558 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routineN)
1559 0 : IF (taskid == root) THEN
1560 0 : msg = res
1561 : END IF
1562 0 : DEALLOCATE (res)
1563 : END IF
1564 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1565 : #else
1566 : MARK_USED(root)
1567 : MARK_USED(msg)
1568 : MARK_USED(comm)
1569 : #endif
1570 0 : CALL mp_timestop(handle)
1571 0 : END SUBROUTINE mp_sum_root_${nametype1}$m
1572 :
1573 : ! **************************************************************************************************
1574 : !> \brief Partial sum of data from all processes with result on each process.
1575 : !> \param[in] msg Matrix to sum (input)
1576 : !> \param[out] res Matrix containing result (output)
1577 : !> \param[in] comm Message passing environment identifier
1578 : ! **************************************************************************************************
1579 108 : SUBROUTINE mp_sum_partial_${nametype1}$m(msg, res, comm)
1580 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:, :)
1581 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: res(:, :)
1582 : CLASS(mp_comm_type), INTENT(IN) :: comm
1583 :
1584 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_partial_${nametype1}$m'
1585 :
1586 : INTEGER :: handle
1587 : #if defined(__parallel)
1588 : INTEGER :: ierr, msglen, taskid
1589 : #endif
1590 :
1591 54 : CALL mp_timeset(routineN, handle)
1592 :
1593 : #if defined(__parallel)
1594 162 : msglen = SIZE(msg)
1595 54 : CALL mpi_comm_rank(comm%handle, taskid, ierr)
1596 54 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ "//routineN)
1597 54 : IF (msglen > 0) THEN
1598 54 : CALL mpi_scan(msg, res, msglen, ${mpi_type1}$, MPI_SUM, comm%handle, ierr)
1599 54 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scan @ "//routineN)
1600 : END IF
1601 54 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1602 : ! perf_id is same as for other summation routines
1603 : #else
1604 : res = msg
1605 : MARK_USED(comm)
1606 : #endif
1607 54 : CALL mp_timestop(handle)
1608 54 : END SUBROUTINE mp_sum_partial_${nametype1}$m
1609 :
1610 : ! **************************************************************************************************
1611 : !> \brief Finds the maximum of a datum with the result left on all processes.
1612 : !> \param[in,out] msg Find maximum among these data (input) and
1613 : !> maximum (output)
1614 : !> \param[in] comm Message passing environment identifier
1615 : !> \par MPI mapping
1616 : !> mpi_allreduce
1617 : ! **************************************************************************************************
1618 12378117 : SUBROUTINE mp_max_${nametype1}$ (msg, comm)
1619 : ${type1}$, INTENT(INOUT) :: msg
1620 : CLASS(mp_comm_type), INTENT(IN) :: comm
1621 :
1622 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_max_${nametype1}$'
1623 :
1624 : INTEGER :: handle
1625 : #if defined(__parallel)
1626 : INTEGER :: ierr, msglen
1627 : #endif
1628 :
1629 12378117 : CALL mp_timeset(routineN, handle)
1630 :
1631 : #if defined(__parallel)
1632 12378117 : msglen = 1
1633 12378117 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_MAX, comm%handle, ierr)
1634 12378117 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1635 12378117 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1636 : #else
1637 : MARK_USED(msg)
1638 : MARK_USED(comm)
1639 : #endif
1640 12378117 : CALL mp_timestop(handle)
1641 12378117 : END SUBROUTINE mp_max_${nametype1}$
1642 :
1643 : ! **************************************************************************************************
1644 : !> \brief Finds the maximum of a datum with the result left on all processes.
1645 : !> \param[in,out] msg Find maximum among these data (input) and
1646 : !> maximum (output)
1647 : !> \param[in] comm Message passing environment identifier
1648 : !> \par MPI mapping
1649 : !> mpi_allreduce
1650 : ! **************************************************************************************************
1651 56 : SUBROUTINE mp_max_root_${nametype1}$ (msg, root, comm)
1652 : ${type1}$, INTENT(INOUT) :: msg
1653 : INTEGER, INTENT(IN) :: root
1654 : CLASS(mp_comm_type), INTENT(IN) :: comm
1655 :
1656 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_max_root_${nametype1}$'
1657 :
1658 : INTEGER :: handle
1659 : #if defined(__parallel)
1660 : INTEGER :: ierr, msglen
1661 : ${type1}$ :: res
1662 : #endif
1663 :
1664 56 : CALL mp_timeset(routineN, handle)
1665 :
1666 : #if defined(__parallel)
1667 56 : msglen = 1
1668 56 : CALL mpi_reduce(msg, res, msglen, ${mpi_type1}$, MPI_MAX, root, comm%handle, ierr)
1669 56 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce @ "//routineN)
1670 56 : IF (root == comm%mepos) msg = res
1671 56 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1672 : #else
1673 : MARK_USED(msg)
1674 : MARK_USED(comm)
1675 : MARK_USED(root)
1676 : #endif
1677 56 : CALL mp_timestop(handle)
1678 56 : END SUBROUTINE mp_max_root_${nametype1}$
1679 :
1680 : ! **************************************************************************************************
1681 : !> \brief Finds the element-wise maximum of a vector with the result left on
1682 : !> all processes.
1683 : !> \param[in,out] msg Find maximum among these data (input) and
1684 : !> maximum (output)
1685 : !> \param comm ...
1686 : !> \note see mp_max_${nametype1}$
1687 : ! **************************************************************************************************
1688 497048 : SUBROUTINE mp_max_${nametype1}$v(msg, comm)
1689 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:)
1690 : CLASS(mp_comm_type), INTENT(IN) :: comm
1691 :
1692 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_max_${nametype1}$v'
1693 :
1694 : INTEGER :: handle
1695 : #if defined(__parallel)
1696 : INTEGER :: ierr, msglen
1697 : #endif
1698 :
1699 497048 : CALL mp_timeset(routineN, handle)
1700 :
1701 : #if defined(__parallel)
1702 497048 : msglen = SIZE(msg)
1703 497048 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_MAX, comm%handle, ierr)
1704 497048 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1705 497048 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1706 : #else
1707 : MARK_USED(msg)
1708 : MARK_USED(comm)
1709 : #endif
1710 497048 : CALL mp_timestop(handle)
1711 497048 : END SUBROUTINE mp_max_${nametype1}$v
1712 :
1713 : ! **************************************************************************************************
1714 : !> \brief Finds the element-wise maximum of a rank2-array with the result left on
1715 : !> all processes.
1716 : !> \param[in] msg Matrix - Find maximum among these data (input) and
1717 : !> maximum (output)
1718 : !> \param comm ...
1719 : !> \note see mp_max_${nametype1}$
1720 : ! **************************************************************************************************
1721 44 : SUBROUTINE mp_max_${nametype1}$m(msg, comm)
1722 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
1723 : CLASS(mp_comm_type), INTENT(IN) :: comm
1724 :
1725 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_max_${nametype1}$m'
1726 :
1727 : INTEGER :: handle
1728 : #if defined(__parallel)
1729 : INTEGER, PARAMETER :: max_msg = 2**25
1730 : INTEGER :: ierr, m1, msglen, step, msglensum
1731 : #endif
1732 :
1733 44 : CALL mp_timeset(routineN, handle)
1734 :
1735 : #if defined(__parallel)
1736 : ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
1737 132 : step = MAX(1, SIZE(msg, 2)/MAX(1, SIZE(msg)/max_msg))
1738 44 : msglensum = 0
1739 132 : DO m1 = LBOUND(msg, 2), UBOUND(msg, 2), step
1740 44 : msglen = SIZE(msg, 1)*(MIN(UBOUND(msg, 2), m1 + step - 1) - m1 + 1)
1741 44 : msglensum = msglensum + msglen
1742 88 : IF (msglen > 0) THEN
1743 44 : CALL mpi_allreduce(MPI_IN_PLACE, msg(LBOUND(msg, 1), m1), msglen, ${mpi_type1}$, MPI_MAX, comm%handle, ierr)
1744 44 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1745 : END IF
1746 : END DO
1747 44 : CALL add_perf(perf_id=3, count=1, msg_size=msglensum*${bytes1}$)
1748 : #else
1749 : MARK_USED(msg)
1750 : MARK_USED(comm)
1751 : #endif
1752 44 : CALL mp_timestop(handle)
1753 44 : END SUBROUTINE mp_max_${nametype1}$m
1754 :
1755 : ! **************************************************************************************************
1756 : !> \brief Finds the element-wise maximum of a vector with the result left on
1757 : !> all processes.
1758 : !> \param[in,out] msg Find maximum among these data (input) and
1759 : !> maximum (output)
1760 : !> \param comm ...
1761 : !> \note see mp_max_${nametype1}$
1762 : ! **************************************************************************************************
1763 2 : SUBROUTINE mp_max_root_${nametype1}$m(msg, root, comm)
1764 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
1765 : INTEGER :: root
1766 : CLASS(mp_comm_type), INTENT(IN) :: comm
1767 :
1768 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_max_root_${nametype1}$m'
1769 :
1770 : INTEGER :: handle
1771 : #if defined(__parallel)
1772 : INTEGER :: ierr, msglen
1773 4 : ${type1}$ :: res(SIZE(msg, 1), SIZE(msg, 2))
1774 : #endif
1775 :
1776 2 : CALL mp_timeset(routineN, handle)
1777 :
1778 : #if defined(__parallel)
1779 6 : msglen = SIZE(msg)
1780 2 : CALL mpi_reduce(msg, res, msglen, ${mpi_type1}$, MPI_MAX, root, comm%handle, ierr)
1781 2 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1782 9 : IF (root == comm%mepos) msg = res
1783 2 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1784 : #else
1785 : MARK_USED(msg)
1786 : MARK_USED(comm)
1787 : MARK_USED(root)
1788 : #endif
1789 2 : CALL mp_timestop(handle)
1790 2 : END SUBROUTINE mp_max_root_${nametype1}$m
1791 :
1792 : ! **************************************************************************************************
1793 : !> \brief Finds the minimum of a datum with the result left on all processes.
1794 : !> \param[in,out] msg Find minimum among these data (input) and
1795 : !> maximum (output)
1796 : !> \param[in] comm Message passing environment identifier
1797 : !> \par MPI mapping
1798 : !> mpi_allreduce
1799 : ! **************************************************************************************************
1800 1766 : SUBROUTINE mp_min_${nametype1}$ (msg, comm)
1801 : ${type1}$, INTENT(INOUT) :: msg
1802 : CLASS(mp_comm_type), INTENT(IN) :: comm
1803 :
1804 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_min_${nametype1}$'
1805 :
1806 : INTEGER :: handle
1807 : #if defined(__parallel)
1808 : INTEGER :: ierr, msglen
1809 : #endif
1810 :
1811 1766 : CALL mp_timeset(routineN, handle)
1812 :
1813 : #if defined(__parallel)
1814 1766 : msglen = 1
1815 1766 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_MIN, comm%handle, ierr)
1816 1766 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1817 1766 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1818 : #else
1819 : MARK_USED(msg)
1820 : MARK_USED(comm)
1821 : #endif
1822 1766 : CALL mp_timestop(handle)
1823 1766 : END SUBROUTINE mp_min_${nametype1}$
1824 :
1825 : ! **************************************************************************************************
1826 : !> \brief Finds the element-wise minimum of vector with the result left on
1827 : !> all processes.
1828 : !> \param[in,out] msg Find minimum among these data (input) and
1829 : !> maximum (output)
1830 : !> \param comm ...
1831 : !> \par MPI mapping
1832 : !> mpi_allreduce
1833 : !> \note see mp_min_${nametype1}$
1834 : ! **************************************************************************************************
1835 45688 : SUBROUTINE mp_min_${nametype1}$v(msg, comm)
1836 : ${type1}$, INTENT(INOUT), CONTIGUOUS :: msg(:)
1837 : CLASS(mp_comm_type), INTENT(IN) :: comm
1838 :
1839 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_min_${nametype1}$v'
1840 :
1841 : INTEGER :: handle
1842 : #if defined(__parallel)
1843 : INTEGER :: ierr, msglen
1844 : #endif
1845 :
1846 45688 : CALL mp_timeset(routineN, handle)
1847 :
1848 : #if defined(__parallel)
1849 45688 : msglen = SIZE(msg)
1850 45688 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_MIN, comm%handle, ierr)
1851 45688 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1852 45688 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1853 : #else
1854 : MARK_USED(msg)
1855 : MARK_USED(comm)
1856 : #endif
1857 45688 : CALL mp_timestop(handle)
1858 45688 : END SUBROUTINE mp_min_${nametype1}$v
1859 :
1860 : ! **************************************************************************************************
1861 : !> \brief Finds the element-wise minimum of a rank2-array with the result left on
1862 : !> all processes.
1863 : !> \param[in] msg Matrix - Find maximum among these data (input) and
1864 : !> minimum (output)
1865 : !> \param comm ...
1866 : !> \note see mp_min_${nametype1}$
1867 : ! **************************************************************************************************
1868 44 : SUBROUTINE mp_min_${nametype1}$m(msg, comm)
1869 : ${type1}$, CONTIGUOUS, INTENT(INOUT) :: msg(:, :)
1870 : CLASS(mp_comm_type), INTENT(IN) :: comm
1871 :
1872 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_min_${nametype1}$m'
1873 :
1874 : INTEGER :: handle
1875 : #if defined(__parallel)
1876 : INTEGER, PARAMETER :: max_msg = 2**25
1877 : INTEGER :: ierr, m1, msglen, step, msglensum
1878 : #endif
1879 :
1880 44 : CALL mp_timeset(routineN, handle)
1881 :
1882 : #if defined(__parallel)
1883 : ! chunk up the call so that message sizes are limited, to avoid overflows in mpich triggered in large rpa calcs
1884 132 : step = MAX(1, SIZE(msg, 2)/MAX(1, SIZE(msg)/max_msg))
1885 44 : msglensum = 0
1886 132 : DO m1 = LBOUND(msg, 2), UBOUND(msg, 2), step
1887 44 : msglen = SIZE(msg, 1)*(MIN(UBOUND(msg, 2), m1 + step - 1) - m1 + 1)
1888 44 : msglensum = msglensum + msglen
1889 88 : IF (msglen > 0) THEN
1890 44 : CALL mpi_allreduce(MPI_IN_PLACE, msg(LBOUND(msg, 1), m1), msglen, ${mpi_type1}$, MPI_MIN, comm%handle, ierr)
1891 44 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1892 : END IF
1893 : END DO
1894 44 : CALL add_perf(perf_id=3, count=1, msg_size=msglensum*${bytes1}$)
1895 : #else
1896 : MARK_USED(msg)
1897 : MARK_USED(comm)
1898 : #endif
1899 44 : CALL mp_timestop(handle)
1900 44 : END SUBROUTINE mp_min_${nametype1}$m
1901 :
1902 : ! **************************************************************************************************
1903 : !> \brief Multiplies a set of numbers scattered across a number of processes,
1904 : !> then replicates the result.
1905 : !> \param[in,out] msg a number to multiply (input) and result (output)
1906 : !> \param[in] comm message passing environment identifier
1907 : !> \par MPI mapping
1908 : !> mpi_allreduce
1909 : ! **************************************************************************************************
1910 6356 : SUBROUTINE mp_prod_${nametype1}$ (msg, comm)
1911 : ${type1}$, INTENT(INOUT) :: msg
1912 : CLASS(mp_comm_type), INTENT(IN) :: comm
1913 :
1914 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_prod_${nametype1}$'
1915 :
1916 : INTEGER :: handle
1917 : #if defined(__parallel)
1918 : INTEGER :: ierr, msglen
1919 : #endif
1920 :
1921 6356 : CALL mp_timeset(routineN, handle)
1922 :
1923 : #if defined(__parallel)
1924 6356 : msglen = 1
1925 6356 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, ${mpi_type1}$, MPI_PROD, comm%handle, ierr)
1926 6356 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
1927 6356 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*${bytes1}$)
1928 : #else
1929 : MARK_USED(msg)
1930 : MARK_USED(comm)
1931 : #endif
1932 6356 : CALL mp_timestop(handle)
1933 6356 : END SUBROUTINE mp_prod_${nametype1}$
1934 :
1935 : ! **************************************************************************************************
1936 : !> \brief Scatters data from one processes to all others
1937 : !> \param[in] msg_scatter Data to scatter (for root process)
1938 : !> \param[out] msg Received data
1939 : !> \param[in] root Process which scatters data
1940 : !> \param[in] comm Message passing environment identifier
1941 : !> \par MPI mapping
1942 : !> mpi_scatter
1943 : ! **************************************************************************************************
1944 0 : SUBROUTINE mp_scatter_${nametype1}$v(msg_scatter, msg, root, comm)
1945 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg_scatter(:)
1946 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msg(:)
1947 : INTEGER, INTENT(IN) :: root
1948 : CLASS(mp_comm_type), INTENT(IN) :: comm
1949 :
1950 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_scatter_${nametype1}$v'
1951 :
1952 : INTEGER :: handle
1953 : #if defined(__parallel)
1954 : INTEGER :: ierr, msglen
1955 : #endif
1956 :
1957 0 : CALL mp_timeset(routineN, handle)
1958 :
1959 : #if defined(__parallel)
1960 0 : msglen = SIZE(msg)
1961 : CALL mpi_scatter(msg_scatter, msglen, ${mpi_type1}$, msg, &
1962 0 : msglen, ${mpi_type1}$, root, comm%handle, ierr)
1963 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_scatter @ "//routineN)
1964 0 : CALL add_perf(perf_id=4, count=1, msg_size=msglen*${bytes1}$)
1965 : #else
1966 : MARK_USED(root)
1967 : MARK_USED(comm)
1968 : msg = msg_scatter
1969 : #endif
1970 0 : CALL mp_timestop(handle)
1971 0 : END SUBROUTINE mp_scatter_${nametype1}$v
1972 :
1973 : ! **************************************************************************************************
1974 : !> \brief Scatters data from one processes to all others
1975 : !> \param[in] msg_scatter Data to scatter (for root process)
1976 : !> \param[in] root Process which scatters data
1977 : !> \param[in] comm Message passing environment identifier
1978 : !> \par MPI mapping
1979 : !> mpi_scatter
1980 : ! **************************************************************************************************
1981 0 : SUBROUTINE mp_iscatter_${nametype1}$ (msg_scatter, msg, root, comm, request)
1982 : ${type1}$, INTENT(IN) :: msg_scatter(:)
1983 : ${type1}$, INTENT(INOUT) :: msg
1984 : INTEGER, INTENT(IN) :: root
1985 : CLASS(mp_comm_type), INTENT(IN) :: comm
1986 : TYPE(mp_request_type), INTENT(OUT) :: request
1987 :
1988 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iscatter_${nametype1}$'
1989 :
1990 : INTEGER :: handle
1991 : #if defined(__parallel)
1992 : INTEGER :: ierr, msglen
1993 : #endif
1994 :
1995 0 : CALL mp_timeset(routineN, handle)
1996 :
1997 : #if defined(__parallel)
1998 : #if !defined(__GNUC__) || __GNUC__ >= 9
1999 0 : CPASSERT(IS_CONTIGUOUS(msg_scatter) .OR. SIZE(msg_scatter) == 0)
2000 : #endif
2001 0 : msglen = 1
2002 : CALL mpi_iscatter(msg_scatter, msglen, ${mpi_type1}$, msg, &
2003 0 : msglen, ${mpi_type1}$, root, comm%handle, request%handle, ierr)
2004 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routineN)
2005 0 : CALL add_perf(perf_id=24, count=1, msg_size=1*${bytes1}$)
2006 : #else
2007 : MARK_USED(root)
2008 : MARK_USED(comm)
2009 : msg = msg_scatter(1)
2010 : request = mp_request_null
2011 : #endif
2012 0 : CALL mp_timestop(handle)
2013 0 : END SUBROUTINE mp_iscatter_${nametype1}$
2014 :
2015 : ! **************************************************************************************************
2016 : !> \brief Scatters data from one processes to all others
2017 : !> \param[in] msg_scatter Data to scatter (for root process)
2018 : !> \param[in] root Process which scatters data
2019 : !> \param[in] comm Message passing environment identifier
2020 : !> \par MPI mapping
2021 : !> mpi_scatter
2022 : ! **************************************************************************************************
2023 0 : SUBROUTINE mp_iscatter_${nametype1}$v2(msg_scatter, msg, root, comm, request)
2024 : ${type1}$, INTENT(IN) :: msg_scatter(:, :)
2025 : ${type1}$, INTENT(INOUT) :: msg(:)
2026 : INTEGER, INTENT(IN) :: root
2027 : CLASS(mp_comm_type), INTENT(IN) :: comm
2028 : TYPE(mp_request_type), INTENT(OUT) :: request
2029 :
2030 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iscatter_${nametype1}$v2'
2031 :
2032 : INTEGER :: handle
2033 : #if defined(__parallel)
2034 : INTEGER :: ierr, msglen
2035 : #endif
2036 :
2037 0 : CALL mp_timeset(routineN, handle)
2038 :
2039 : #if defined(__parallel)
2040 : #if !defined(__GNUC__) || __GNUC__ >= 9
2041 0 : CPASSERT(IS_CONTIGUOUS(msg_scatter) .OR. SIZE(msg_scatter) == 0)
2042 : #endif
2043 0 : msglen = SIZE(msg)
2044 : CALL mpi_iscatter(msg_scatter, msglen, ${mpi_type1}$, msg, &
2045 0 : msglen, ${mpi_type1}$, root, comm%handle, request%handle, ierr)
2046 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatter @ "//routineN)
2047 0 : CALL add_perf(perf_id=24, count=1, msg_size=1*${bytes1}$)
2048 : #else
2049 : MARK_USED(root)
2050 : MARK_USED(comm)
2051 : msg(:) = msg_scatter(:, 1)
2052 : request = mp_request_null
2053 : #endif
2054 0 : CALL mp_timestop(handle)
2055 0 : END SUBROUTINE mp_iscatter_${nametype1}$v2
2056 :
2057 : ! **************************************************************************************************
2058 : !> \brief Scatters data from one processes to all others
2059 : !> \param[in] msg_scatter Data to scatter (for root process)
2060 : !> \param[in] root Process which scatters data
2061 : !> \param[in] comm Message passing environment identifier
2062 : !> \par MPI mapping
2063 : !> mpi_scatter
2064 : ! **************************************************************************************************
2065 0 : SUBROUTINE mp_iscatterv_${nametype1}$v(msg_scatter, sendcounts, displs, msg, recvcount, root, comm, request)
2066 : ${type1}$, INTENT(IN) :: msg_scatter(:)
2067 : INTEGER, INTENT(IN) :: sendcounts(:), displs(:)
2068 : ${type1}$, INTENT(INOUT) :: msg(:)
2069 : INTEGER, INTENT(IN) :: recvcount, root
2070 : CLASS(mp_comm_type), INTENT(IN) :: comm
2071 : TYPE(mp_request_type), INTENT(OUT) :: request
2072 :
2073 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iscatterv_${nametype1}$v'
2074 :
2075 : INTEGER :: handle
2076 : #if defined(__parallel)
2077 : INTEGER :: ierr
2078 : #endif
2079 :
2080 0 : CALL mp_timeset(routineN, handle)
2081 :
2082 : #if defined(__parallel)
2083 : #if !defined(__GNUC__) || __GNUC__ >= 9
2084 0 : CPASSERT(IS_CONTIGUOUS(msg_scatter) .OR. SIZE(msg_scatter) == 0)
2085 0 : CPASSERT(IS_CONTIGUOUS(msg) .OR. SIZE(msg) == 0)
2086 0 : CPASSERT(IS_CONTIGUOUS(sendcounts) .OR. SIZE(sendcounts) == 0)
2087 0 : CPASSERT(IS_CONTIGUOUS(displs) .OR. SIZE(displs) == 0)
2088 : #endif
2089 : CALL mpi_iscatterv(msg_scatter, sendcounts, displs, ${mpi_type1}$, msg, &
2090 0 : recvcount, ${mpi_type1}$, root, comm%handle, request%handle, ierr)
2091 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iscatterv @ "//routineN)
2092 0 : CALL add_perf(perf_id=24, count=1, msg_size=1*${bytes1}$)
2093 : #else
2094 : MARK_USED(sendcounts)
2095 : MARK_USED(displs)
2096 : MARK_USED(recvcount)
2097 : MARK_USED(root)
2098 : MARK_USED(comm)
2099 : msg(1:recvcount) = msg_scatter(1 + displs(1):1 + displs(1) + sendcounts(1))
2100 : request = mp_request_null
2101 : #endif
2102 0 : CALL mp_timestop(handle)
2103 0 : END SUBROUTINE mp_iscatterv_${nametype1}$v
2104 :
2105 : ! **************************************************************************************************
2106 : !> \brief Gathers a datum from all processes to one
2107 : !> \param[in] msg Datum to send to root
2108 : !> \param[out] msg_gather Received data (on root)
2109 : !> \param[in] root Process which gathers the data
2110 : !> \param[in] comm Message passing environment identifier
2111 : !> \par MPI mapping
2112 : !> mpi_gather
2113 : ! **************************************************************************************************
2114 0 : SUBROUTINE mp_gather_${nametype1}$ (msg, msg_gather, root, comm)
2115 : ${type1}$, INTENT(IN) :: msg
2116 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
2117 : INTEGER, INTENT(IN) :: root
2118 : CLASS(mp_comm_type), INTENT(IN) :: comm
2119 :
2120 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gather_${nametype1}$'
2121 :
2122 : INTEGER :: handle
2123 : #if defined(__parallel)
2124 : INTEGER :: ierr, msglen
2125 : #endif
2126 :
2127 0 : CALL mp_timeset(routineN, handle)
2128 :
2129 : #if defined(__parallel)
2130 0 : msglen = 1
2131 : CALL mpi_gather(msg, msglen, ${mpi_type1}$, msg_gather, &
2132 0 : msglen, ${mpi_type1}$, root, comm%handle, ierr)
2133 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routineN)
2134 0 : CALL add_perf(perf_id=4, count=1, msg_size=msglen*${bytes1}$)
2135 : #else
2136 : MARK_USED(root)
2137 : MARK_USED(comm)
2138 : msg_gather(1) = msg
2139 : #endif
2140 0 : CALL mp_timestop(handle)
2141 0 : END SUBROUTINE mp_gather_${nametype1}$
2142 :
2143 : ! **************************************************************************************************
2144 : !> \brief Gathers a datum from all processes to one, uses the source process of comm
2145 : !> \param[in] msg Datum to send to root
2146 : !> \param[out] msg_gather Received data (on root)
2147 : !> \param[in] comm Message passing environment identifier
2148 : !> \par MPI mapping
2149 : !> mpi_gather
2150 : ! **************************************************************************************************
2151 30 : SUBROUTINE mp_gather_${nametype1}$_src(msg, msg_gather, comm)
2152 : ${type1}$, INTENT(IN) :: msg
2153 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
2154 : CLASS(mp_comm_type), INTENT(IN) :: comm
2155 :
2156 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gather_${nametype1}$_src'
2157 :
2158 : INTEGER :: handle
2159 : #if defined(__parallel)
2160 : INTEGER :: ierr, msglen
2161 : #endif
2162 :
2163 30 : CALL mp_timeset(routineN, handle)
2164 :
2165 : #if defined(__parallel)
2166 30 : msglen = 1
2167 : CALL mpi_gather(msg, msglen, ${mpi_type1}$, msg_gather, &
2168 30 : msglen, ${mpi_type1}$, comm%source, comm%handle, ierr)
2169 30 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routineN)
2170 30 : CALL add_perf(perf_id=4, count=1, msg_size=msglen*${bytes1}$)
2171 : #else
2172 : MARK_USED(comm)
2173 : msg_gather(1) = msg
2174 : #endif
2175 30 : CALL mp_timestop(handle)
2176 30 : END SUBROUTINE mp_gather_${nametype1}$_src
2177 :
2178 : ! **************************************************************************************************
2179 : !> \brief Gathers data from all processes to one
2180 : !> \param[in] msg Datum to send to root
2181 : !> \param msg_gather ...
2182 : !> \param root ...
2183 : !> \param comm ...
2184 : !> \par Data length
2185 : !> All data (msg) is equal-sized
2186 : !> \par MPI mapping
2187 : !> mpi_gather
2188 : !> \note see mp_gather_${nametype1}$
2189 : ! **************************************************************************************************
2190 0 : SUBROUTINE mp_gather_${nametype1}$v(msg, msg_gather, root, comm)
2191 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:)
2192 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
2193 : INTEGER, INTENT(IN) :: root
2194 : CLASS(mp_comm_type), INTENT(IN) :: comm
2195 :
2196 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gather_${nametype1}$v'
2197 :
2198 : INTEGER :: handle
2199 : #if defined(__parallel)
2200 : INTEGER :: ierr, msglen
2201 : #endif
2202 :
2203 0 : CALL mp_timeset(routineN, handle)
2204 :
2205 : #if defined(__parallel)
2206 0 : msglen = SIZE(msg)
2207 : CALL mpi_gather(msg, msglen, ${mpi_type1}$, msg_gather, &
2208 0 : msglen, ${mpi_type1}$, root, comm%handle, ierr)
2209 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routineN)
2210 0 : CALL add_perf(perf_id=4, count=1, msg_size=msglen*${bytes1}$)
2211 : #else
2212 : MARK_USED(root)
2213 : MARK_USED(comm)
2214 : msg_gather = msg
2215 : #endif
2216 0 : CALL mp_timestop(handle)
2217 0 : END SUBROUTINE mp_gather_${nametype1}$v
2218 :
2219 : ! **************************************************************************************************
2220 : !> \brief Gathers data from all processes to one. Gathers from comm%source
2221 : !> \param[in] msg Datum to send to root
2222 : !> \param msg_gather ...
2223 : !> \param comm ...
2224 : !> \par Data length
2225 : !> All data (msg) is equal-sized
2226 : !> \par MPI mapping
2227 : !> mpi_gather
2228 : !> \note see mp_gather_${nametype1}$
2229 : ! **************************************************************************************************
2230 0 : SUBROUTINE mp_gather_${nametype1}$v_src(msg, msg_gather, comm)
2231 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:)
2232 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msg_gather(:)
2233 : CLASS(mp_comm_type), INTENT(IN) :: comm
2234 :
2235 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gather_${nametype1}$v_src'
2236 :
2237 : INTEGER :: handle
2238 : #if defined(__parallel)
2239 : INTEGER :: ierr, msglen
2240 : #endif
2241 :
2242 0 : CALL mp_timeset(routineN, handle)
2243 :
2244 : #if defined(__parallel)
2245 0 : msglen = SIZE(msg)
2246 : CALL mpi_gather(msg, msglen, ${mpi_type1}$, msg_gather, &
2247 0 : msglen, ${mpi_type1}$, comm%source, comm%handle, ierr)
2248 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routineN)
2249 0 : CALL add_perf(perf_id=4, count=1, msg_size=msglen*${bytes1}$)
2250 : #else
2251 : MARK_USED(comm)
2252 : msg_gather = msg
2253 : #endif
2254 0 : CALL mp_timestop(handle)
2255 0 : END SUBROUTINE mp_gather_${nametype1}$v_src
2256 :
2257 : ! **************************************************************************************************
2258 : !> \brief Gathers data from all processes to one
2259 : !> \param[in] msg Datum to send to root
2260 : !> \param msg_gather ...
2261 : !> \param root ...
2262 : !> \param comm ...
2263 : !> \par Data length
2264 : !> All data (msg) is equal-sized
2265 : !> \par MPI mapping
2266 : !> mpi_gather
2267 : !> \note see mp_gather_${nametype1}$
2268 : ! **************************************************************************************************
2269 0 : SUBROUTINE mp_gather_${nametype1}$m(msg, msg_gather, root, comm)
2270 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:, :)
2271 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
2272 : INTEGER, INTENT(IN) :: root
2273 : CLASS(mp_comm_type), INTENT(IN) :: comm
2274 :
2275 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gather_${nametype1}$m'
2276 :
2277 : INTEGER :: handle
2278 : #if defined(__parallel)
2279 : INTEGER :: ierr, msglen
2280 : #endif
2281 :
2282 0 : CALL mp_timeset(routineN, handle)
2283 :
2284 : #if defined(__parallel)
2285 0 : msglen = SIZE(msg)
2286 : CALL mpi_gather(msg, msglen, ${mpi_type1}$, msg_gather, &
2287 0 : msglen, ${mpi_type1}$, root, comm%handle, ierr)
2288 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routineN)
2289 0 : CALL add_perf(perf_id=4, count=1, msg_size=msglen*${bytes1}$)
2290 : #else
2291 : MARK_USED(root)
2292 : MARK_USED(comm)
2293 : msg_gather = msg
2294 : #endif
2295 0 : CALL mp_timestop(handle)
2296 0 : END SUBROUTINE mp_gather_${nametype1}$m
2297 :
2298 : ! **************************************************************************************************
2299 : !> \brief Gathers data from all processes to one. Gathers from comm%source
2300 : !> \param[in] msg Datum to send to root
2301 : !> \param msg_gather ...
2302 : !> \param comm ...
2303 : !> \par Data length
2304 : !> All data (msg) is equal-sized
2305 : !> \par MPI mapping
2306 : !> mpi_gather
2307 : !> \note see mp_gather_${nametype1}$
2308 : ! **************************************************************************************************
2309 82 : SUBROUTINE mp_gather_${nametype1}$m_src(msg, msg_gather, comm)
2310 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:, :)
2311 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msg_gather(:, :)
2312 : CLASS(mp_comm_type), INTENT(IN) :: comm
2313 :
2314 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gather_${nametype1}$m_src'
2315 :
2316 : INTEGER :: handle
2317 : #if defined(__parallel)
2318 : INTEGER :: ierr, msglen
2319 : #endif
2320 :
2321 82 : CALL mp_timeset(routineN, handle)
2322 :
2323 : #if defined(__parallel)
2324 246 : msglen = SIZE(msg)
2325 : CALL mpi_gather(msg, msglen, ${mpi_type1}$, msg_gather, &
2326 82 : msglen, ${mpi_type1}$, comm%source, comm%handle, ierr)
2327 82 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gather @ "//routineN)
2328 82 : CALL add_perf(perf_id=4, count=1, msg_size=msglen*${bytes1}$)
2329 : #else
2330 : MARK_USED(comm)
2331 : msg_gather = msg
2332 : #endif
2333 82 : CALL mp_timestop(handle)
2334 82 : END SUBROUTINE mp_gather_${nametype1}$m_src
2335 :
2336 : ! **************************************************************************************************
2337 : !> \brief Gathers data from all processes to one.
2338 : !> \param[in] sendbuf Data to send to root
2339 : !> \param[out] recvbuf Received data (on root)
2340 : !> \param[in] recvcounts Sizes of data received from processes
2341 : !> \param[in] displs Offsets of data received from processes
2342 : !> \param[in] root Process which gathers the data
2343 : !> \param[in] comm Message passing environment identifier
2344 : !> \par Data length
2345 : !> Data can have different lengths
2346 : !> \par Offsets
2347 : !> Offsets start at 0
2348 : !> \par MPI mapping
2349 : !> mpi_gather
2350 : ! **************************************************************************************************
2351 0 : SUBROUTINE mp_gatherv_${nametype1}$v(sendbuf, recvbuf, recvcounts, displs, root, comm)
2352 :
2353 : ${type1}$, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
2354 : ${type1}$, DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
2355 : INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
2356 : INTEGER, INTENT(IN) :: root
2357 : CLASS(mp_comm_type), INTENT(IN) :: comm
2358 :
2359 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gatherv_${nametype1}$v'
2360 :
2361 : INTEGER :: handle
2362 : #if defined(__parallel)
2363 : INTEGER :: ierr, sendcount
2364 : #endif
2365 :
2366 0 : CALL mp_timeset(routineN, handle)
2367 :
2368 : #if defined(__parallel)
2369 0 : sendcount = SIZE(sendbuf)
2370 : CALL mpi_gatherv(sendbuf, sendcount, ${mpi_type1}$, &
2371 : recvbuf, recvcounts, displs, ${mpi_type1}$, &
2372 0 : root, comm%handle, ierr)
2373 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routineN)
2374 : CALL add_perf(perf_id=4, &
2375 : count=1, &
2376 0 : msg_size=sendcount*${bytes1}$)
2377 : #else
2378 : MARK_USED(recvcounts)
2379 : MARK_USED(root)
2380 : MARK_USED(comm)
2381 : recvbuf(1 + displs(1):) = sendbuf
2382 : #endif
2383 0 : CALL mp_timestop(handle)
2384 0 : END SUBROUTINE mp_gatherv_${nametype1}$v
2385 :
2386 : ! **************************************************************************************************
2387 : !> \brief Gathers data from all processes to one. Gathers from comm%source
2388 : !> \param[in] sendbuf Data to send to root
2389 : !> \param[out] recvbuf Received data (on root)
2390 : !> \param[in] recvcounts Sizes of data received from processes
2391 : !> \param[in] displs Offsets of data received from processes
2392 : !> \param[in] comm Message passing environment identifier
2393 : !> \par Data length
2394 : !> Data can have different lengths
2395 : !> \par Offsets
2396 : !> Offsets start at 0
2397 : !> \par MPI mapping
2398 : !> mpi_gather
2399 : ! **************************************************************************************************
2400 210 : SUBROUTINE mp_gatherv_${nametype1}$v_src(sendbuf, recvbuf, recvcounts, displs, comm)
2401 :
2402 : ${type1}$, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: sendbuf
2403 : ${type1}$, DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: recvbuf
2404 : INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
2405 : CLASS(mp_comm_type), INTENT(IN) :: comm
2406 :
2407 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gatherv_${nametype1}$v_src'
2408 :
2409 : INTEGER :: handle
2410 : #if defined(__parallel)
2411 : INTEGER :: ierr, sendcount
2412 : #endif
2413 :
2414 210 : CALL mp_timeset(routineN, handle)
2415 :
2416 : #if defined(__parallel)
2417 210 : sendcount = SIZE(sendbuf)
2418 : CALL mpi_gatherv(sendbuf, sendcount, ${mpi_type1}$, &
2419 : recvbuf, recvcounts, displs, ${mpi_type1}$, &
2420 210 : comm%source, comm%handle, ierr)
2421 210 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routineN)
2422 : CALL add_perf(perf_id=4, &
2423 : count=1, &
2424 210 : msg_size=sendcount*${bytes1}$)
2425 : #else
2426 : MARK_USED(recvcounts)
2427 : MARK_USED(comm)
2428 : recvbuf(1 + displs(1):) = sendbuf
2429 : #endif
2430 210 : CALL mp_timestop(handle)
2431 210 : END SUBROUTINE mp_gatherv_${nametype1}$v_src
2432 :
2433 : ! **************************************************************************************************
2434 : !> \brief Gathers data from all processes to one.
2435 : !> \param[in] sendbuf Data to send to root
2436 : !> \param[out] recvbuf Received data (on root)
2437 : !> \param[in] recvcounts Sizes of data received from processes
2438 : !> \param[in] displs Offsets of data received from processes
2439 : !> \param[in] root Process which gathers the data
2440 : !> \param[in] comm Message passing environment identifier
2441 : !> \par Data length
2442 : !> Data can have different lengths
2443 : !> \par Offsets
2444 : !> Offsets start at 0
2445 : !> \par MPI mapping
2446 : !> mpi_gather
2447 : ! **************************************************************************************************
2448 0 : SUBROUTINE mp_gatherv_${nametype1}$m2(sendbuf, recvbuf, recvcounts, displs, root, comm)
2449 :
2450 : ${type1}$, DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
2451 : ${type1}$, DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
2452 : INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
2453 : INTEGER, INTENT(IN) :: root
2454 : CLASS(mp_comm_type), INTENT(IN) :: comm
2455 :
2456 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gatherv_${nametype1}$m2'
2457 :
2458 : INTEGER :: handle
2459 : #if defined(__parallel)
2460 : INTEGER :: ierr, sendcount
2461 : #endif
2462 :
2463 0 : CALL mp_timeset(routineN, handle)
2464 :
2465 : #if defined(__parallel)
2466 0 : sendcount = SIZE(sendbuf)
2467 : CALL mpi_gatherv(sendbuf, sendcount, ${mpi_type1}$, &
2468 : recvbuf, recvcounts, displs, ${mpi_type1}$, &
2469 0 : root, comm%handle, ierr)
2470 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routineN)
2471 : CALL add_perf(perf_id=4, &
2472 : count=1, &
2473 0 : msg_size=sendcount*${bytes1}$)
2474 : #else
2475 : MARK_USED(recvcounts)
2476 : MARK_USED(root)
2477 : MARK_USED(comm)
2478 : recvbuf(:, 1 + displs(1):) = sendbuf
2479 : #endif
2480 0 : CALL mp_timestop(handle)
2481 0 : END SUBROUTINE mp_gatherv_${nametype1}$m2
2482 :
2483 : ! **************************************************************************************************
2484 : !> \brief Gathers data from all processes to one.
2485 : !> \param[in] sendbuf Data to send to root
2486 : !> \param[out] recvbuf Received data (on root)
2487 : !> \param[in] recvcounts Sizes of data received from processes
2488 : !> \param[in] displs Offsets of data received from processes
2489 : !> \param[in] comm Message passing environment identifier
2490 : !> \par Data length
2491 : !> Data can have different lengths
2492 : !> \par Offsets
2493 : !> Offsets start at 0
2494 : !> \par MPI mapping
2495 : !> mpi_gather
2496 : ! **************************************************************************************************
2497 0 : SUBROUTINE mp_gatherv_${nametype1}$m2_src(sendbuf, recvbuf, recvcounts, displs, comm)
2498 :
2499 : ${type1}$, DIMENSION(:, :), CONTIGUOUS, INTENT(IN) :: sendbuf
2500 : ${type1}$, DIMENSION(:, :), CONTIGUOUS, INTENT(OUT) :: recvbuf
2501 : INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
2502 : CLASS(mp_comm_type), INTENT(IN) :: comm
2503 :
2504 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_gatherv_${nametype1}$m2_src'
2505 :
2506 : INTEGER :: handle
2507 : #if defined(__parallel)
2508 : INTEGER :: ierr, sendcount
2509 : #endif
2510 :
2511 0 : CALL mp_timeset(routineN, handle)
2512 :
2513 : #if defined(__parallel)
2514 0 : sendcount = SIZE(sendbuf)
2515 : CALL mpi_gatherv(sendbuf, sendcount, ${mpi_type1}$, &
2516 : recvbuf, recvcounts, displs, ${mpi_type1}$, &
2517 0 : comm%source, comm%handle, ierr)
2518 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routineN)
2519 : CALL add_perf(perf_id=4, &
2520 : count=1, &
2521 0 : msg_size=sendcount*${bytes1}$)
2522 : #else
2523 : MARK_USED(recvcounts)
2524 : MARK_USED(comm)
2525 : recvbuf(:, 1 + displs(1):) = sendbuf
2526 : #endif
2527 0 : CALL mp_timestop(handle)
2528 0 : END SUBROUTINE mp_gatherv_${nametype1}$m2_src
2529 :
2530 : ! **************************************************************************************************
2531 : !> \brief Gathers data from all processes to one.
2532 : !> \param[in] sendbuf Data to send to root
2533 : !> \param[out] recvbuf Received data (on root)
2534 : !> \param[in] recvcounts Sizes of data received from processes
2535 : !> \param[in] displs Offsets of data received from processes
2536 : !> \param[in] root Process which gathers the data
2537 : !> \param[in] comm Message passing environment identifier
2538 : !> \par Data length
2539 : !> Data can have different lengths
2540 : !> \par Offsets
2541 : !> Offsets start at 0
2542 : !> \par MPI mapping
2543 : !> mpi_gather
2544 : ! **************************************************************************************************
2545 0 : SUBROUTINE mp_igatherv_${nametype1}$v(sendbuf, sendcount, recvbuf, recvcounts, displs, root, comm, request)
2546 : ${type1}$, DIMENSION(:), INTENT(IN) :: sendbuf
2547 : ${type1}$, DIMENSION(:), INTENT(OUT) :: recvbuf
2548 : INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: recvcounts, displs
2549 : INTEGER, INTENT(IN) :: sendcount, root
2550 : CLASS(mp_comm_type), INTENT(IN) :: comm
2551 : TYPE(mp_request_type), INTENT(OUT) :: request
2552 :
2553 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_igatherv_${nametype1}$v'
2554 :
2555 : INTEGER :: handle
2556 : #if defined(__parallel)
2557 : INTEGER :: ierr
2558 : #endif
2559 :
2560 0 : CALL mp_timeset(routineN, handle)
2561 :
2562 : #if defined(__parallel)
2563 : #if !defined(__GNUC__) || __GNUC__ >= 9
2564 0 : CPASSERT(IS_CONTIGUOUS(sendbuf) .OR. SIZE(sendbuf) == 0)
2565 0 : CPASSERT(IS_CONTIGUOUS(recvbuf) .OR. SIZE(recvbuf) == 0)
2566 0 : CPASSERT(IS_CONTIGUOUS(recvcounts) .OR. SIZE(recvcounts) == 0)
2567 0 : CPASSERT(IS_CONTIGUOUS(displs) .OR. SIZE(displs) == 0)
2568 : #endif
2569 : CALL mpi_igatherv(sendbuf, sendcount, ${mpi_type1}$, &
2570 : recvbuf, recvcounts, displs, ${mpi_type1}$, &
2571 0 : root, comm%handle, request%handle, ierr)
2572 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_gatherv @ "//routineN)
2573 : CALL add_perf(perf_id=24, &
2574 : count=1, &
2575 0 : msg_size=sendcount*${bytes1}$)
2576 : #else
2577 : MARK_USED(sendcount)
2578 : MARK_USED(recvcounts)
2579 : MARK_USED(root)
2580 : MARK_USED(comm)
2581 : recvbuf(1 + displs(1):1 + displs(1) + recvcounts(1)) = sendbuf(1:sendcount)
2582 : request = mp_request_null
2583 : #endif
2584 0 : CALL mp_timestop(handle)
2585 0 : END SUBROUTINE mp_igatherv_${nametype1}$v
2586 :
2587 : ! **************************************************************************************************
2588 : !> \brief Gathers a datum from all processes and all processes receive the
2589 : !> same data
2590 : !> \param[in] msgout Datum to send
2591 : !> \param[out] msgin Received data
2592 : !> \param[in] comm Message passing environment identifier
2593 : !> \par Data size
2594 : !> All processes send equal-sized data
2595 : !> \par MPI mapping
2596 : !> mpi_allgather
2597 : ! **************************************************************************************************
2598 393522 : SUBROUTINE mp_allgather_${nametype1}$ (msgout, msgin, comm)
2599 : ${type1}$, INTENT(IN) :: msgout
2600 : ${type1}$, INTENT(OUT), CONTIGUOUS :: msgin(:)
2601 : CLASS(mp_comm_type), INTENT(IN) :: comm
2602 :
2603 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_allgather_${nametype1}$'
2604 :
2605 : INTEGER :: handle
2606 : #if defined(__parallel)
2607 : INTEGER :: ierr, rcount, scount
2608 : #endif
2609 :
2610 393522 : CALL mp_timeset(routineN, handle)
2611 :
2612 : #if defined(__parallel)
2613 393522 : scount = 1
2614 393522 : rcount = 1
2615 : CALL MPI_ALLGATHER(msgout, scount, ${mpi_type1}$, &
2616 : msgin, rcount, ${mpi_type1}$, &
2617 393522 : comm%handle, ierr)
2618 393522 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routineN)
2619 : #else
2620 : MARK_USED(comm)
2621 : msgin = msgout
2622 : #endif
2623 393522 : CALL mp_timestop(handle)
2624 393522 : END SUBROUTINE mp_allgather_${nametype1}$
2625 :
2626 : ! **************************************************************************************************
2627 : !> \brief Gathers a datum from all processes and all processes receive the
2628 : !> same data
2629 : !> \param[in] msgout Datum to send
2630 : !> \param[out] msgin Received data
2631 : !> \param[in] comm Message passing environment identifier
2632 : !> \par Data size
2633 : !> All processes send equal-sized data
2634 : !> \par MPI mapping
2635 : !> mpi_allgather
2636 : ! **************************************************************************************************
2637 0 : SUBROUTINE mp_allgather_${nametype1}$2(msgout, msgin, comm)
2638 : ${type1}$, INTENT(IN) :: msgout
2639 : ${type1}$, INTENT(OUT), CONTIGUOUS :: msgin(:, :)
2640 : CLASS(mp_comm_type), INTENT(IN) :: comm
2641 :
2642 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_allgather_${nametype1}$2'
2643 :
2644 : INTEGER :: handle
2645 : #if defined(__parallel)
2646 : INTEGER :: ierr, rcount, scount
2647 : #endif
2648 :
2649 0 : CALL mp_timeset(routineN, handle)
2650 :
2651 : #if defined(__parallel)
2652 0 : scount = 1
2653 0 : rcount = 1
2654 : CALL MPI_ALLGATHER(msgout, scount, ${mpi_type1}$, &
2655 : msgin, rcount, ${mpi_type1}$, &
2656 0 : comm%handle, ierr)
2657 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routineN)
2658 : #else
2659 : MARK_USED(comm)
2660 : msgin = msgout
2661 : #endif
2662 0 : CALL mp_timestop(handle)
2663 0 : END SUBROUTINE mp_allgather_${nametype1}$2
2664 :
2665 : ! **************************************************************************************************
2666 : !> \brief Gathers a datum from all processes and all processes receive the
2667 : !> same data
2668 : !> \param[in] msgout Datum to send
2669 : !> \param[out] msgin Received data
2670 : !> \param[in] comm Message passing environment identifier
2671 : !> \par Data size
2672 : !> All processes send equal-sized data
2673 : !> \par MPI mapping
2674 : !> mpi_allgather
2675 : ! **************************************************************************************************
2676 0 : SUBROUTINE mp_iallgather_${nametype1}$ (msgout, msgin, comm, request)
2677 : ${type1}$, INTENT(IN) :: msgout
2678 : ${type1}$, INTENT(OUT) :: msgin(:)
2679 : CLASS(mp_comm_type), INTENT(IN) :: comm
2680 : TYPE(mp_request_type), INTENT(OUT) :: request
2681 :
2682 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iallgather_${nametype1}$'
2683 :
2684 : INTEGER :: handle
2685 : #if defined(__parallel)
2686 : INTEGER :: ierr, rcount, scount
2687 : #endif
2688 :
2689 0 : CALL mp_timeset(routineN, handle)
2690 :
2691 : #if defined(__parallel)
2692 : #if !defined(__GNUC__) || __GNUC__ >= 9
2693 0 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
2694 : #endif
2695 0 : scount = 1
2696 0 : rcount = 1
2697 : CALL MPI_IALLGATHER(msgout, scount, ${mpi_type1}$, &
2698 : msgin, rcount, ${mpi_type1}$, &
2699 0 : comm%handle, request%handle, ierr)
2700 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routineN)
2701 : #else
2702 : MARK_USED(comm)
2703 : msgin = msgout
2704 : request = mp_request_null
2705 : #endif
2706 0 : CALL mp_timestop(handle)
2707 0 : END SUBROUTINE mp_iallgather_${nametype1}$
2708 :
2709 : ! **************************************************************************************************
2710 : !> \brief Gathers vector data from all processes and all processes receive the
2711 : !> same data
2712 : !> \param[in] msgout Rank-1 data to send
2713 : !> \param[out] msgin Received data
2714 : !> \param[in] comm Message passing environment identifier
2715 : !> \par Data size
2716 : !> All processes send equal-sized data
2717 : !> \par Ranks
2718 : !> The last rank counts the processes
2719 : !> \par MPI mapping
2720 : !> mpi_allgather
2721 : ! **************************************************************************************************
2722 4974 : SUBROUTINE mp_allgather_${nametype1}$12(msgout, msgin, comm)
2723 : ${type1}$, INTENT(IN), CONTIGUOUS :: msgout(:)
2724 : ${type1}$, INTENT(OUT), CONTIGUOUS :: msgin(:, :)
2725 : CLASS(mp_comm_type), INTENT(IN) :: comm
2726 :
2727 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_allgather_${nametype1}$12'
2728 :
2729 : INTEGER :: handle
2730 : #if defined(__parallel)
2731 : INTEGER :: ierr, rcount, scount
2732 : #endif
2733 :
2734 4974 : CALL mp_timeset(routineN, handle)
2735 :
2736 : #if defined(__parallel)
2737 4974 : scount = SIZE(msgout(:))
2738 4974 : rcount = scount
2739 : CALL MPI_ALLGATHER(msgout, scount, ${mpi_type1}$, &
2740 : msgin, rcount, ${mpi_type1}$, &
2741 4974 : comm%handle, ierr)
2742 4974 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routineN)
2743 : #else
2744 : MARK_USED(comm)
2745 : msgin(:, 1) = msgout(:)
2746 : #endif
2747 4974 : CALL mp_timestop(handle)
2748 4974 : END SUBROUTINE mp_allgather_${nametype1}$12
2749 :
2750 : ! **************************************************************************************************
2751 : !> \brief Gathers matrix data from all processes and all processes receive the
2752 : !> same data
2753 : !> \param[in] msgout Rank-2 data to send
2754 : !> \param msgin ...
2755 : !> \param comm ...
2756 : !> \note see mp_allgather_${nametype1}$12
2757 : ! **************************************************************************************************
2758 89224 : SUBROUTINE mp_allgather_${nametype1}$23(msgout, msgin, comm)
2759 : ${type1}$, INTENT(IN), CONTIGUOUS :: msgout(:, :)
2760 : ${type1}$, INTENT(OUT), CONTIGUOUS :: msgin(:, :, :)
2761 : CLASS(mp_comm_type), INTENT(IN) :: comm
2762 :
2763 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_allgather_${nametype1}$23'
2764 :
2765 : INTEGER :: handle
2766 : #if defined(__parallel)
2767 : INTEGER :: ierr, rcount, scount
2768 : #endif
2769 :
2770 89224 : CALL mp_timeset(routineN, handle)
2771 :
2772 : #if defined(__parallel)
2773 267672 : scount = SIZE(msgout(:, :))
2774 89224 : rcount = scount
2775 : CALL MPI_ALLGATHER(msgout, scount, ${mpi_type1}$, &
2776 : msgin, rcount, ${mpi_type1}$, &
2777 89224 : comm%handle, ierr)
2778 89224 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routineN)
2779 : #else
2780 : MARK_USED(comm)
2781 : msgin(:, :, 1) = msgout(:, :)
2782 : #endif
2783 89224 : CALL mp_timestop(handle)
2784 89224 : END SUBROUTINE mp_allgather_${nametype1}$23
2785 :
2786 : ! **************************************************************************************************
2787 : !> \brief Gathers rank-3 data from all processes and all processes receive the
2788 : !> same data
2789 : !> \param[in] msgout Rank-3 data to send
2790 : !> \param msgin ...
2791 : !> \param comm ...
2792 : !> \note see mp_allgather_${nametype1}$12
2793 : ! **************************************************************************************************
2794 442 : SUBROUTINE mp_allgather_${nametype1}$34(msgout, msgin, comm)
2795 : ${type1}$, INTENT(IN), CONTIGUOUS :: msgout(:, :, :)
2796 : ${type1}$, INTENT(OUT), CONTIGUOUS :: msgin(:, :, :, :)
2797 : CLASS(mp_comm_type), INTENT(IN) :: comm
2798 :
2799 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_allgather_${nametype1}$34'
2800 :
2801 : INTEGER :: handle
2802 : #if defined(__parallel)
2803 : INTEGER :: ierr, rcount, scount
2804 : #endif
2805 :
2806 442 : CALL mp_timeset(routineN, handle)
2807 :
2808 : #if defined(__parallel)
2809 1768 : scount = SIZE(msgout(:, :, :))
2810 442 : rcount = scount
2811 : CALL MPI_ALLGATHER(msgout, scount, ${mpi_type1}$, &
2812 : msgin, rcount, ${mpi_type1}$, &
2813 442 : comm%handle, ierr)
2814 442 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routineN)
2815 : #else
2816 : MARK_USED(comm)
2817 : msgin(:, :, :, 1) = msgout(:, :, :)
2818 : #endif
2819 442 : CALL mp_timestop(handle)
2820 442 : END SUBROUTINE mp_allgather_${nametype1}$34
2821 :
2822 : ! **************************************************************************************************
2823 : !> \brief Gathers rank-2 data from all processes and all processes receive the
2824 : !> same data
2825 : !> \param[in] msgout Rank-2 data to send
2826 : !> \param msgin ...
2827 : !> \param comm ...
2828 : !> \note see mp_allgather_${nametype1}$12
2829 : ! **************************************************************************************************
2830 0 : SUBROUTINE mp_allgather_${nametype1}$22(msgout, msgin, comm)
2831 : ${type1}$, INTENT(IN), CONTIGUOUS :: msgout(:, :)
2832 : ${type1}$, INTENT(OUT), CONTIGUOUS :: msgin(:, :)
2833 : CLASS(mp_comm_type), INTENT(IN) :: comm
2834 :
2835 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_allgather_${nametype1}$22'
2836 :
2837 : INTEGER :: handle
2838 : #if defined(__parallel)
2839 : INTEGER :: ierr, rcount, scount
2840 : #endif
2841 :
2842 0 : CALL mp_timeset(routineN, handle)
2843 :
2844 : #if defined(__parallel)
2845 0 : scount = SIZE(msgout(:, :))
2846 0 : rcount = scount
2847 : CALL MPI_ALLGATHER(msgout, scount, ${mpi_type1}$, &
2848 : msgin, rcount, ${mpi_type1}$, &
2849 0 : comm%handle, ierr)
2850 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgather @ "//routineN)
2851 : #else
2852 : MARK_USED(comm)
2853 : msgin(:, :) = msgout(:, :)
2854 : #endif
2855 0 : CALL mp_timestop(handle)
2856 0 : END SUBROUTINE mp_allgather_${nametype1}$22
2857 :
2858 : ! **************************************************************************************************
2859 : !> \brief Gathers rank-1 data from all processes and all processes receive the
2860 : !> same data
2861 : !> \param[in] msgout Rank-1 data to send
2862 : !> \param msgin ...
2863 : !> \param comm ...
2864 : !> \param request ...
2865 : !> \note see mp_allgather_${nametype1}$11
2866 : ! **************************************************************************************************
2867 0 : SUBROUTINE mp_iallgather_${nametype1}$11(msgout, msgin, comm, request)
2868 : ${type1}$, INTENT(IN) :: msgout(:)
2869 : ${type1}$, INTENT(OUT) :: msgin(:)
2870 : CLASS(mp_comm_type), INTENT(IN) :: comm
2871 : TYPE(mp_request_type), INTENT(OUT) :: request
2872 :
2873 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iallgather_${nametype1}$11'
2874 :
2875 : INTEGER :: handle
2876 : #if defined(__parallel)
2877 : INTEGER :: ierr, rcount, scount
2878 : #endif
2879 :
2880 0 : CALL mp_timeset(routineN, handle)
2881 :
2882 : #if defined(__parallel)
2883 : #if !defined(__GNUC__) || __GNUC__ >= 9
2884 0 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
2885 0 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
2886 : #endif
2887 0 : scount = SIZE(msgout(:))
2888 0 : rcount = scount
2889 : CALL MPI_IALLGATHER(msgout, scount, ${mpi_type1}$, &
2890 : msgin, rcount, ${mpi_type1}$, &
2891 0 : comm%handle, request%handle, ierr)
2892 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routineN)
2893 : #else
2894 : MARK_USED(comm)
2895 : msgin = msgout
2896 : request = mp_request_null
2897 : #endif
2898 0 : CALL mp_timestop(handle)
2899 0 : END SUBROUTINE mp_iallgather_${nametype1}$11
2900 :
2901 : ! **************************************************************************************************
2902 : !> \brief Gathers rank-2 data from all processes and all processes receive the
2903 : !> same data
2904 : !> \param[in] msgout Rank-2 data to send
2905 : !> \param msgin ...
2906 : !> \param comm ...
2907 : !> \param request ...
2908 : !> \note see mp_allgather_${nametype1}$12
2909 : ! **************************************************************************************************
2910 0 : SUBROUTINE mp_iallgather_${nametype1}$13(msgout, msgin, comm, request)
2911 : ${type1}$, INTENT(IN) :: msgout(:)
2912 : ${type1}$, INTENT(OUT) :: msgin(:, :, :)
2913 : CLASS(mp_comm_type), INTENT(IN) :: comm
2914 : TYPE(mp_request_type), INTENT(OUT) :: request
2915 :
2916 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iallgather_${nametype1}$13'
2917 :
2918 : INTEGER :: handle
2919 : #if defined(__parallel)
2920 : INTEGER :: ierr, rcount, scount
2921 : #endif
2922 :
2923 0 : CALL mp_timeset(routineN, handle)
2924 :
2925 : #if defined(__parallel)
2926 : #if !defined(__GNUC__) || __GNUC__ >= 9
2927 0 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
2928 0 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
2929 : #endif
2930 :
2931 0 : scount = SIZE(msgout(:))
2932 0 : rcount = scount
2933 : CALL MPI_IALLGATHER(msgout, scount, ${mpi_type1}$, &
2934 : msgin, rcount, ${mpi_type1}$, &
2935 0 : comm%handle, request%handle, ierr)
2936 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routineN)
2937 : #else
2938 : MARK_USED(comm)
2939 : msgin(:, 1, 1) = msgout(:)
2940 : request = mp_request_null
2941 : #endif
2942 0 : CALL mp_timestop(handle)
2943 0 : END SUBROUTINE mp_iallgather_${nametype1}$13
2944 :
2945 : ! **************************************************************************************************
2946 : !> \brief Gathers rank-2 data from all processes and all processes receive the
2947 : !> same data
2948 : !> \param[in] msgout Rank-2 data to send
2949 : !> \param msgin ...
2950 : !> \param comm ...
2951 : !> \param request ...
2952 : !> \note see mp_allgather_${nametype1}$12
2953 : ! **************************************************************************************************
2954 0 : SUBROUTINE mp_iallgather_${nametype1}$22(msgout, msgin, comm, request)
2955 : ${type1}$, INTENT(IN) :: msgout(:, :)
2956 : ${type1}$, INTENT(OUT) :: msgin(:, :)
2957 : CLASS(mp_comm_type), INTENT(IN) :: comm
2958 : TYPE(mp_request_type), INTENT(OUT) :: request
2959 :
2960 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iallgather_${nametype1}$22'
2961 :
2962 : INTEGER :: handle
2963 : #if defined(__parallel)
2964 : INTEGER :: ierr, rcount, scount
2965 : #endif
2966 :
2967 0 : CALL mp_timeset(routineN, handle)
2968 :
2969 : #if defined(__parallel)
2970 : #if !defined(__GNUC__) || __GNUC__ >= 9
2971 0 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
2972 0 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
2973 : #endif
2974 :
2975 0 : scount = SIZE(msgout(:, :))
2976 0 : rcount = scount
2977 : CALL MPI_IALLGATHER(msgout, scount, ${mpi_type1}$, &
2978 : msgin, rcount, ${mpi_type1}$, &
2979 0 : comm%handle, request%handle, ierr)
2980 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routineN)
2981 : #else
2982 : MARK_USED(comm)
2983 : msgin(:, :) = msgout(:, :)
2984 : request = mp_request_null
2985 : #endif
2986 0 : CALL mp_timestop(handle)
2987 0 : END SUBROUTINE mp_iallgather_${nametype1}$22
2988 :
2989 : ! **************************************************************************************************
2990 : !> \brief Gathers rank-2 data from all processes and all processes receive the
2991 : !> same data
2992 : !> \param[in] msgout Rank-2 data to send
2993 : !> \param msgin ...
2994 : !> \param comm ...
2995 : !> \param request ...
2996 : !> \note see mp_allgather_${nametype1}$12
2997 : ! **************************************************************************************************
2998 0 : SUBROUTINE mp_iallgather_${nametype1}$24(msgout, msgin, comm, request)
2999 : ${type1}$, INTENT(IN) :: msgout(:, :)
3000 : ${type1}$, INTENT(OUT) :: msgin(:, :, :, :)
3001 : CLASS(mp_comm_type), INTENT(IN) :: comm
3002 : TYPE(mp_request_type), INTENT(OUT) :: request
3003 :
3004 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iallgather_${nametype1}$24'
3005 :
3006 : INTEGER :: handle
3007 : #if defined(__parallel)
3008 : INTEGER :: ierr, rcount, scount
3009 : #endif
3010 :
3011 0 : CALL mp_timeset(routineN, handle)
3012 :
3013 : #if defined(__parallel)
3014 : #if !defined(__GNUC__) || __GNUC__ >= 9
3015 0 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
3016 0 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
3017 : #endif
3018 :
3019 0 : scount = SIZE(msgout(:, :))
3020 0 : rcount = scount
3021 : CALL MPI_IALLGATHER(msgout, scount, ${mpi_type1}$, &
3022 : msgin, rcount, ${mpi_type1}$, &
3023 0 : comm%handle, request%handle, ierr)
3024 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routineN)
3025 : #else
3026 : MARK_USED(comm)
3027 : msgin(:, :, 1, 1) = msgout(:, :)
3028 : request = mp_request_null
3029 : #endif
3030 0 : CALL mp_timestop(handle)
3031 0 : END SUBROUTINE mp_iallgather_${nametype1}$24
3032 :
3033 : ! **************************************************************************************************
3034 : !> \brief Gathers rank-3 data from all processes and all processes receive the
3035 : !> same data
3036 : !> \param[in] msgout Rank-3 data to send
3037 : !> \param msgin ...
3038 : !> \param comm ...
3039 : !> \param request ...
3040 : !> \note see mp_allgather_${nametype1}$12
3041 : ! **************************************************************************************************
3042 0 : SUBROUTINE mp_iallgather_${nametype1}$33(msgout, msgin, comm, request)
3043 : ${type1}$, INTENT(IN) :: msgout(:, :, :)
3044 : ${type1}$, INTENT(OUT) :: msgin(:, :, :)
3045 : CLASS(mp_comm_type), INTENT(IN) :: comm
3046 : TYPE(mp_request_type), INTENT(OUT) :: request
3047 :
3048 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iallgather_${nametype1}$33'
3049 :
3050 : INTEGER :: handle
3051 : #if defined(__parallel)
3052 : INTEGER :: ierr, rcount, scount
3053 : #endif
3054 :
3055 0 : CALL mp_timeset(routineN, handle)
3056 :
3057 : #if defined(__parallel)
3058 : #if !defined(__GNUC__) || __GNUC__ >= 9
3059 0 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
3060 0 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
3061 : #endif
3062 :
3063 0 : scount = SIZE(msgout(:, :, :))
3064 0 : rcount = scount
3065 : CALL MPI_IALLGATHER(msgout, scount, ${mpi_type1}$, &
3066 : msgin, rcount, ${mpi_type1}$, &
3067 0 : comm%handle, request%handle, ierr)
3068 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgather @ "//routineN)
3069 : #else
3070 : MARK_USED(comm)
3071 : msgin(:, :, :) = msgout(:, :, :)
3072 : request = mp_request_null
3073 : #endif
3074 0 : CALL mp_timestop(handle)
3075 0 : END SUBROUTINE mp_iallgather_${nametype1}$33
3076 :
3077 : ! **************************************************************************************************
3078 : !> \brief Gathers vector data from all processes and all processes receive the
3079 : !> same data
3080 : !> \param[in] msgout Rank-1 data to send
3081 : !> \param[out] msgin Received data
3082 : !> \param[in] rcount Size of sent data for every process
3083 : !> \param[in] rdispl Offset of sent data for every process
3084 : !> \param[in] comm Message passing environment identifier
3085 : !> \par Data size
3086 : !> Processes can send different-sized data
3087 : !> \par Ranks
3088 : !> The last rank counts the processes
3089 : !> \par Offsets
3090 : !> Offsets are from 0
3091 : !> \par MPI mapping
3092 : !> mpi_allgather
3093 : ! **************************************************************************************************
3094 268142 : SUBROUTINE mp_allgatherv_${nametype1}$v(msgout, msgin, rcount, rdispl, comm)
3095 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msgout(:)
3096 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msgin(:)
3097 : INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
3098 : CLASS(mp_comm_type), INTENT(IN) :: comm
3099 :
3100 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_allgatherv_${nametype1}$v'
3101 :
3102 : INTEGER :: handle
3103 : #if defined(__parallel)
3104 : INTEGER :: ierr, scount
3105 : #endif
3106 :
3107 268142 : CALL mp_timeset(routineN, handle)
3108 :
3109 : #if defined(__parallel)
3110 268142 : scount = SIZE(msgout)
3111 : CALL MPI_ALLGATHERV(msgout, scount, ${mpi_type1}$, msgin, rcount, &
3112 268142 : rdispl, ${mpi_type1}$, comm%handle, ierr)
3113 268142 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routineN)
3114 : #else
3115 : MARK_USED(rcount)
3116 : MARK_USED(rdispl)
3117 : MARK_USED(comm)
3118 : msgin = msgout
3119 : #endif
3120 268142 : CALL mp_timestop(handle)
3121 268142 : END SUBROUTINE mp_allgatherv_${nametype1}$v
3122 :
3123 : ! **************************************************************************************************
3124 : !> \brief Gathers vector data from all processes and all processes receive the
3125 : !> same data
3126 : !> \param[in] msgout Rank-1 data to send
3127 : !> \param[out] msgin Received data
3128 : !> \param[in] rcount Size of sent data for every process
3129 : !> \param[in] rdispl Offset of sent data for every process
3130 : !> \param[in] comm Message passing environment identifier
3131 : !> \par Data size
3132 : !> Processes can send different-sized data
3133 : !> \par Ranks
3134 : !> The last rank counts the processes
3135 : !> \par Offsets
3136 : !> Offsets are from 0
3137 : !> \par MPI mapping
3138 : !> mpi_allgather
3139 : ! **************************************************************************************************
3140 8 : SUBROUTINE mp_allgatherv_${nametype1}$m2(msgout, msgin, rcount, rdispl, comm)
3141 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msgout(:, :)
3142 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msgin(:, :)
3143 : INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
3144 : CLASS(mp_comm_type), INTENT(IN) :: comm
3145 :
3146 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_allgatherv_${nametype1}$v'
3147 :
3148 : INTEGER :: handle
3149 : #if defined(__parallel)
3150 : INTEGER :: ierr, scount
3151 : #endif
3152 :
3153 8 : CALL mp_timeset(routineN, handle)
3154 :
3155 : #if defined(__parallel)
3156 24 : scount = SIZE(msgout)
3157 : CALL MPI_ALLGATHERV(msgout, scount, ${mpi_type1}$, msgin, rcount, &
3158 8 : rdispl, ${mpi_type1}$, comm%handle, ierr)
3159 8 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allgatherv @ "//routineN)
3160 : #else
3161 : MARK_USED(rcount)
3162 : MARK_USED(rdispl)
3163 : MARK_USED(comm)
3164 : msgin = msgout
3165 : #endif
3166 8 : CALL mp_timestop(handle)
3167 8 : END SUBROUTINE mp_allgatherv_${nametype1}$m2
3168 :
3169 : ! **************************************************************************************************
3170 : !> \brief Gathers vector data from all processes and all processes receive the
3171 : !> same data
3172 : !> \param[in] msgout Rank-1 data to send
3173 : !> \param[out] msgin Received data
3174 : !> \param[in] rcount Size of sent data for every process
3175 : !> \param[in] rdispl Offset of sent data for every process
3176 : !> \param[in] comm Message passing environment identifier
3177 : !> \par Data size
3178 : !> Processes can send different-sized data
3179 : !> \par Ranks
3180 : !> The last rank counts the processes
3181 : !> \par Offsets
3182 : !> Offsets are from 0
3183 : !> \par MPI mapping
3184 : !> mpi_allgather
3185 : ! **************************************************************************************************
3186 0 : SUBROUTINE mp_iallgatherv_${nametype1}$v(msgout, msgin, rcount, rdispl, comm, request)
3187 : ${type1}$, INTENT(IN) :: msgout(:)
3188 : ${type1}$, INTENT(OUT) :: msgin(:)
3189 : INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:), rdispl(:)
3190 : CLASS(mp_comm_type), INTENT(IN) :: comm
3191 : TYPE(mp_request_type), INTENT(OUT) :: request
3192 :
3193 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iallgatherv_${nametype1}$v'
3194 :
3195 : INTEGER :: handle
3196 : #if defined(__parallel)
3197 : INTEGER :: ierr, scount, rsize
3198 : #endif
3199 :
3200 0 : CALL mp_timeset(routineN, handle)
3201 :
3202 : #if defined(__parallel)
3203 : #if !defined(__GNUC__) || __GNUC__ >= 9
3204 0 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
3205 0 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
3206 0 : CPASSERT(IS_CONTIGUOUS(rcount) .OR. SIZE(rcount) == 0)
3207 0 : CPASSERT(IS_CONTIGUOUS(rdispl) .OR. SIZE(rdispl) == 0)
3208 : #endif
3209 :
3210 0 : scount = SIZE(msgout)
3211 0 : rsize = SIZE(rcount)
3212 : CALL mp_iallgatherv_${nametype1}$v_internal(msgout, scount, msgin, rsize, rcount, &
3213 0 : rdispl, comm, request, ierr)
3214 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routineN)
3215 : #else
3216 : MARK_USED(rcount)
3217 : MARK_USED(rdispl)
3218 : MARK_USED(comm)
3219 : msgin = msgout
3220 : request = mp_request_null
3221 : #endif
3222 0 : CALL mp_timestop(handle)
3223 0 : END SUBROUTINE mp_iallgatherv_${nametype1}$v
3224 :
3225 : ! **************************************************************************************************
3226 : !> \brief Gathers vector data from all processes and all processes receive the
3227 : !> same data
3228 : !> \param[in] msgout Rank-1 data to send
3229 : !> \param[out] msgin Received data
3230 : !> \param[in] rcount Size of sent data for every process
3231 : !> \param[in] rdispl Offset of sent data for every process
3232 : !> \param[in] comm Message passing environment identifier
3233 : !> \par Data size
3234 : !> Processes can send different-sized data
3235 : !> \par Ranks
3236 : !> The last rank counts the processes
3237 : !> \par Offsets
3238 : !> Offsets are from 0
3239 : !> \par MPI mapping
3240 : !> mpi_allgather
3241 : ! **************************************************************************************************
3242 0 : SUBROUTINE mp_iallgatherv_${nametype1}$v2(msgout, msgin, rcount, rdispl, comm, request)
3243 : ${type1}$, INTENT(IN) :: msgout(:)
3244 : ${type1}$, INTENT(OUT) :: msgin(:)
3245 : INTEGER, INTENT(IN) :: rcount(:, :), rdispl(:, :)
3246 : CLASS(mp_comm_type), INTENT(IN) :: comm
3247 : TYPE(mp_request_type), INTENT(OUT) :: request
3248 :
3249 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_iallgatherv_${nametype1}$v2'
3250 :
3251 : INTEGER :: handle
3252 : #if defined(__parallel)
3253 : INTEGER :: ierr, scount, rsize
3254 : #endif
3255 :
3256 0 : CALL mp_timeset(routineN, handle)
3257 :
3258 : #if defined(__parallel)
3259 : #if !defined(__GNUC__) || __GNUC__ >= 9
3260 0 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
3261 0 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
3262 0 : CPASSERT(IS_CONTIGUOUS(rcount) .OR. SIZE(rcount) == 0)
3263 0 : CPASSERT(IS_CONTIGUOUS(rdispl) .OR. SIZE(rdispl) == 0)
3264 : #endif
3265 :
3266 0 : scount = SIZE(msgout)
3267 0 : rsize = SIZE(rcount)
3268 : CALL mp_iallgatherv_${nametype1}$v_internal(msgout, scount, msgin, rsize, rcount, &
3269 0 : rdispl, comm, request, ierr)
3270 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iallgatherv @ "//routineN)
3271 : #else
3272 : MARK_USED(rcount)
3273 : MARK_USED(rdispl)
3274 : MARK_USED(comm)
3275 : msgin = msgout
3276 : request = mp_request_null
3277 : #endif
3278 0 : CALL mp_timestop(handle)
3279 0 : END SUBROUTINE mp_iallgatherv_${nametype1}$v2
3280 :
3281 : ! **************************************************************************************************
3282 : !> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
3283 : !> the issue is with the rank of rcount and rdispl
3284 : !> \param count ...
3285 : !> \param array_of_requests ...
3286 : !> \param array_of_statuses ...
3287 : !> \param ierr ...
3288 : !> \author Alfio Lazzaro
3289 : ! **************************************************************************************************
3290 : #if defined(__parallel)
3291 0 : SUBROUTINE mp_iallgatherv_${nametype1}$v_internal(msgout, scount, msgin, rsize, rcount, rdispl, comm, request, ierr)
3292 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msgout(:)
3293 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msgin(:)
3294 : INTEGER, INTENT(IN) :: rsize
3295 : INTEGER, INTENT(IN) :: rcount(rsize), rdispl(rsize), scount
3296 : CLASS(mp_comm_type), INTENT(IN) :: comm
3297 : TYPE(mp_request_type), INTENT(OUT) :: request
3298 : INTEGER, INTENT(INOUT) :: ierr
3299 :
3300 : CALL MPI_IALLGATHERV(msgout, scount, ${mpi_type1}$, msgin, rcount, &
3301 0 : rdispl, ${mpi_type1}$, comm%handle, request%handle, ierr)
3302 :
3303 0 : END SUBROUTINE mp_iallgatherv_${nametype1}$v_internal
3304 : #endif
3305 :
3306 : ! **************************************************************************************************
3307 : !> \brief Sums a vector and partitions the result among processes
3308 : !> \param[in] msgout Data to sum
3309 : !> \param[out] msgin Received portion of summed data
3310 : !> \param[in] rcount Partition sizes of the summed data for
3311 : !> every process
3312 : !> \param[in] comm Message passing environment identifier
3313 : ! **************************************************************************************************
3314 6 : SUBROUTINE mp_sum_scatter_${nametype1}$v(msgout, msgin, rcount, comm)
3315 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msgout(:, :)
3316 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msgin(:)
3317 : INTEGER, CONTIGUOUS, INTENT(IN) :: rcount(:)
3318 : CLASS(mp_comm_type), INTENT(IN) :: comm
3319 :
3320 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_scatter_${nametype1}$v'
3321 :
3322 : INTEGER :: handle
3323 : #if defined(__parallel)
3324 : INTEGER :: ierr
3325 : #endif
3326 :
3327 6 : CALL mp_timeset(routineN, handle)
3328 :
3329 : #if defined(__parallel)
3330 : CALL MPI_REDUCE_SCATTER(msgout, msgin, rcount, ${mpi_type1}$, MPI_SUM, &
3331 6 : comm%handle, ierr)
3332 6 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_reduce_scatter @ "//routineN)
3333 :
3334 : CALL add_perf(perf_id=3, count=1, &
3335 6 : msg_size=rcount(1)*2*${bytes1}$)
3336 : #else
3337 : MARK_USED(rcount)
3338 : MARK_USED(comm)
3339 : msgin = msgout(:, 1)
3340 : #endif
3341 6 : CALL mp_timestop(handle)
3342 6 : END SUBROUTINE mp_sum_scatter_${nametype1}$v
3343 :
3344 : ! **************************************************************************************************
3345 : !> \brief Sends and receives vector data
3346 : !> \param[in] msgin Data to send
3347 : !> \param[in] dest Process to send data to
3348 : !> \param[out] msgout Received data
3349 : !> \param[in] source Process from which to receive
3350 : !> \param[in] comm Message passing environment identifier
3351 : !> \param[in] tag Send and recv tag (default: 0)
3352 : ! **************************************************************************************************
3353 0 : SUBROUTINE mp_sendrecv_${nametype1}$ (msgin, dest, msgout, source, comm, tag)
3354 : ${type1}$, INTENT(IN) :: msgin
3355 : INTEGER, INTENT(IN) :: dest
3356 : ${type1}$, INTENT(OUT) :: msgout
3357 : INTEGER, INTENT(IN) :: source
3358 : CLASS(mp_comm_type), INTENT(IN) :: comm
3359 : INTEGER, INTENT(IN), OPTIONAL :: tag
3360 :
3361 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sendrecv_${nametype1}$'
3362 :
3363 : INTEGER :: handle
3364 : #if defined(__parallel)
3365 : INTEGER :: ierr, msglen_in, msglen_out, &
3366 : recv_tag, send_tag
3367 : #endif
3368 :
3369 0 : CALL mp_timeset(routineN, handle)
3370 :
3371 : #if defined(__parallel)
3372 0 : msglen_in = 1
3373 0 : msglen_out = 1
3374 0 : send_tag = 0 ! cannot think of something better here, this might be dangerous
3375 0 : recv_tag = 0 ! cannot think of something better here, this might be dangerous
3376 0 : IF (PRESENT(tag)) THEN
3377 0 : send_tag = tag
3378 0 : recv_tag = tag
3379 : END IF
3380 : CALL mpi_sendrecv(msgin, msglen_in, ${mpi_type1}$, dest, send_tag, msgout, &
3381 0 : msglen_out, ${mpi_type1}$, source, recv_tag, comm%handle, MPI_STATUS_IGNORE, ierr)
3382 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routineN)
3383 : CALL add_perf(perf_id=7, count=1, &
3384 0 : msg_size=(msglen_in + msglen_out)*${bytes1}$/2)
3385 : #else
3386 : MARK_USED(dest)
3387 : MARK_USED(source)
3388 : MARK_USED(comm)
3389 : MARK_USED(tag)
3390 : msgout = msgin
3391 : #endif
3392 0 : CALL mp_timestop(handle)
3393 0 : END SUBROUTINE mp_sendrecv_${nametype1}$
3394 :
3395 : ! **************************************************************************************************
3396 : !> \brief Sends and receives vector data
3397 : !> \param[in] msgin Data to send
3398 : !> \param[in] dest Process to send data to
3399 : !> \param[out] msgout Received data
3400 : !> \param[in] source Process from which to receive
3401 : !> \param[in] comm Message passing environment identifier
3402 : !> \param[in] tag Send and recv tag (default: 0)
3403 : ! **************************************************************************************************
3404 918850 : SUBROUTINE mp_sendrecv_${nametype1}$v(msgin, dest, msgout, source, comm, tag)
3405 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msgin(:)
3406 : INTEGER, INTENT(IN) :: dest
3407 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msgout(:)
3408 : INTEGER, INTENT(IN) :: source
3409 : CLASS(mp_comm_type), INTENT(IN) :: comm
3410 : INTEGER, INTENT(IN), OPTIONAL :: tag
3411 :
3412 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sendrecv_${nametype1}$v'
3413 :
3414 : INTEGER :: handle
3415 : #if defined(__parallel)
3416 : INTEGER :: ierr, msglen_in, msglen_out, &
3417 : recv_tag, send_tag
3418 : #endif
3419 :
3420 918850 : CALL mp_timeset(routineN, handle)
3421 :
3422 : #if defined(__parallel)
3423 918850 : msglen_in = SIZE(msgin)
3424 918850 : msglen_out = SIZE(msgout)
3425 918850 : send_tag = 0 ! cannot think of something better here, this might be dangerous
3426 918850 : recv_tag = 0 ! cannot think of something better here, this might be dangerous
3427 918850 : IF (PRESENT(tag)) THEN
3428 918724 : send_tag = tag
3429 918724 : recv_tag = tag
3430 : END IF
3431 : CALL mpi_sendrecv(msgin, msglen_in, ${mpi_type1}$, dest, send_tag, msgout, &
3432 918850 : msglen_out, ${mpi_type1}$, source, recv_tag, comm%handle, MPI_STATUS_IGNORE, ierr)
3433 918850 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routineN)
3434 : CALL add_perf(perf_id=7, count=1, &
3435 918850 : msg_size=(msglen_in + msglen_out)*${bytes1}$/2)
3436 : #else
3437 : MARK_USED(dest)
3438 : MARK_USED(source)
3439 : MARK_USED(comm)
3440 : MARK_USED(tag)
3441 : msgout = msgin
3442 : #endif
3443 918850 : CALL mp_timestop(handle)
3444 918850 : END SUBROUTINE mp_sendrecv_${nametype1}$v
3445 :
3446 : ! **************************************************************************************************
3447 : !> \brief Sends and receives matrix data
3448 : !> \param msgin ...
3449 : !> \param dest ...
3450 : !> \param msgout ...
3451 : !> \param source ...
3452 : !> \param comm ...
3453 : !> \param tag ...
3454 : !> \note see mp_sendrecv_${nametype1}$v
3455 : ! **************************************************************************************************
3456 149914 : SUBROUTINE mp_sendrecv_${nametype1}$m2(msgin, dest, msgout, source, comm, tag)
3457 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msgin(:, :)
3458 : INTEGER, INTENT(IN) :: dest
3459 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msgout(:, :)
3460 : INTEGER, INTENT(IN) :: source
3461 : CLASS(mp_comm_type), INTENT(IN) :: comm
3462 : INTEGER, INTENT(IN), OPTIONAL :: tag
3463 :
3464 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sendrecv_${nametype1}$m2'
3465 :
3466 : INTEGER :: handle
3467 : #if defined(__parallel)
3468 : INTEGER :: ierr, msglen_in, msglen_out, &
3469 : recv_tag, send_tag
3470 : #endif
3471 :
3472 149914 : CALL mp_timeset(routineN, handle)
3473 :
3474 : #if defined(__parallel)
3475 149914 : msglen_in = SIZE(msgin, 1)*SIZE(msgin, 2)
3476 149914 : msglen_out = SIZE(msgout, 1)*SIZE(msgout, 2)
3477 149914 : send_tag = 0 ! cannot think of something better here, this might be dangerous
3478 149914 : recv_tag = 0 ! cannot think of something better here, this might be dangerous
3479 149914 : IF (PRESENT(tag)) THEN
3480 654 : send_tag = tag
3481 654 : recv_tag = tag
3482 : END IF
3483 : CALL mpi_sendrecv(msgin, msglen_in, ${mpi_type1}$, dest, send_tag, msgout, &
3484 149914 : msglen_out, ${mpi_type1}$, source, recv_tag, comm%handle, MPI_STATUS_IGNORE, ierr)
3485 149914 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routineN)
3486 : CALL add_perf(perf_id=7, count=1, &
3487 149914 : msg_size=(msglen_in + msglen_out)*${bytes1}$/2)
3488 : #else
3489 : MARK_USED(dest)
3490 : MARK_USED(source)
3491 : MARK_USED(comm)
3492 : MARK_USED(tag)
3493 : msgout = msgin
3494 : #endif
3495 149914 : CALL mp_timestop(handle)
3496 149914 : END SUBROUTINE mp_sendrecv_${nametype1}$m2
3497 :
3498 : ! **************************************************************************************************
3499 : !> \brief Sends and receives rank-3 data
3500 : !> \param msgin ...
3501 : !> \param dest ...
3502 : !> \param msgout ...
3503 : !> \param source ...
3504 : !> \param comm ...
3505 : !> \note see mp_sendrecv_${nametype1}$v
3506 : ! **************************************************************************************************
3507 87702 : SUBROUTINE mp_sendrecv_${nametype1}$m3(msgin, dest, msgout, source, comm, tag)
3508 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msgin(:, :, :)
3509 : INTEGER, INTENT(IN) :: dest
3510 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :)
3511 : INTEGER, INTENT(IN) :: source
3512 : CLASS(mp_comm_type), INTENT(IN) :: comm
3513 : INTEGER, INTENT(IN), OPTIONAL :: tag
3514 :
3515 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sendrecv_${nametype1}$m3'
3516 :
3517 : INTEGER :: handle
3518 : #if defined(__parallel)
3519 : INTEGER :: ierr, msglen_in, msglen_out, &
3520 : recv_tag, send_tag
3521 : #endif
3522 :
3523 87702 : CALL mp_timeset(routineN, handle)
3524 :
3525 : #if defined(__parallel)
3526 350808 : msglen_in = SIZE(msgin)
3527 350808 : msglen_out = SIZE(msgout)
3528 87702 : send_tag = 0 ! cannot think of something better here, this might be dangerous
3529 87702 : recv_tag = 0 ! cannot think of something better here, this might be dangerous
3530 87702 : IF (PRESENT(tag)) THEN
3531 484 : send_tag = tag
3532 484 : recv_tag = tag
3533 : END IF
3534 : CALL mpi_sendrecv(msgin, msglen_in, ${mpi_type1}$, dest, send_tag, msgout, &
3535 87702 : msglen_out, ${mpi_type1}$, source, recv_tag, comm%handle, MPI_STATUS_IGNORE, ierr)
3536 87702 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routineN)
3537 : CALL add_perf(perf_id=7, count=1, &
3538 87702 : msg_size=(msglen_in + msglen_out)*${bytes1}$/2)
3539 : #else
3540 : MARK_USED(dest)
3541 : MARK_USED(source)
3542 : MARK_USED(comm)
3543 : MARK_USED(tag)
3544 : msgout = msgin
3545 : #endif
3546 87702 : CALL mp_timestop(handle)
3547 87702 : END SUBROUTINE mp_sendrecv_${nametype1}$m3
3548 :
3549 : ! **************************************************************************************************
3550 : !> \brief Sends and receives rank-4 data
3551 : !> \param msgin ...
3552 : !> \param dest ...
3553 : !> \param msgout ...
3554 : !> \param source ...
3555 : !> \param comm ...
3556 : !> \note see mp_sendrecv_${nametype1}$v
3557 : ! **************************************************************************************************
3558 0 : SUBROUTINE mp_sendrecv_${nametype1}$m4(msgin, dest, msgout, source, comm, tag)
3559 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msgin(:, :, :, :)
3560 : INTEGER, INTENT(IN) :: dest
3561 : ${type1}$, CONTIGUOUS, INTENT(OUT) :: msgout(:, :, :, :)
3562 : INTEGER, INTENT(IN) :: source
3563 : CLASS(mp_comm_type), INTENT(IN) :: comm
3564 : INTEGER, INTENT(IN), OPTIONAL :: tag
3565 :
3566 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sendrecv_${nametype1}$m4'
3567 :
3568 : INTEGER :: handle
3569 : #if defined(__parallel)
3570 : INTEGER :: ierr, msglen_in, msglen_out, &
3571 : recv_tag, send_tag
3572 : #endif
3573 :
3574 0 : CALL mp_timeset(routineN, handle)
3575 :
3576 : #if defined(__parallel)
3577 0 : msglen_in = SIZE(msgin)
3578 0 : msglen_out = SIZE(msgout)
3579 0 : send_tag = 0 ! cannot think of something better here, this might be dangerous
3580 0 : recv_tag = 0 ! cannot think of something better here, this might be dangerous
3581 0 : IF (PRESENT(tag)) THEN
3582 0 : send_tag = tag
3583 0 : recv_tag = tag
3584 : END IF
3585 : CALL mpi_sendrecv(msgin, msglen_in, ${mpi_type1}$, dest, send_tag, msgout, &
3586 0 : msglen_out, ${mpi_type1}$, source, recv_tag, comm%handle, MPI_STATUS_IGNORE, ierr)
3587 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_sendrecv @ "//routineN)
3588 : CALL add_perf(perf_id=7, count=1, &
3589 0 : msg_size=(msglen_in + msglen_out)*${bytes1}$/2)
3590 : #else
3591 : MARK_USED(dest)
3592 : MARK_USED(source)
3593 : MARK_USED(comm)
3594 : MARK_USED(tag)
3595 : msgout = msgin
3596 : #endif
3597 0 : CALL mp_timestop(handle)
3598 0 : END SUBROUTINE mp_sendrecv_${nametype1}$m4
3599 :
3600 : ! **************************************************************************************************
3601 : !> \brief Non-blocking send and receive of a scalar
3602 : !> \param[in] msgin Scalar data to send
3603 : !> \param[in] dest Which process to send to
3604 : !> \param[out] msgout Receive data into this pointer
3605 : !> \param[in] source Process to receive from
3606 : !> \param[in] comm Message passing environment identifier
3607 : !> \param[out] send_request Request handle for the send
3608 : !> \param[out] recv_request Request handle for the receive
3609 : !> \param[in] tag (optional) tag to differentiate requests
3610 : !> \par Implementation
3611 : !> Calls mpi_isend and mpi_irecv.
3612 : !> \par History
3613 : !> 02.2005 created [Alfio Lazzaro]
3614 : ! **************************************************************************************************
3615 0 : SUBROUTINE mp_isendrecv_${nametype1}$ (msgin, dest, msgout, source, comm, send_request, &
3616 : recv_request, tag)
3617 : ${type1}$, INTENT(IN) :: msgin
3618 : INTEGER, INTENT(IN) :: dest
3619 : ${type1}$, INTENT(INOUT) :: msgout
3620 : INTEGER, INTENT(IN) :: source
3621 : CLASS(mp_comm_type), INTENT(IN) :: comm
3622 : TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
3623 : INTEGER, INTENT(in), OPTIONAL :: tag
3624 :
3625 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isendrecv_${nametype1}$'
3626 :
3627 : INTEGER :: handle
3628 : #if defined(__parallel)
3629 : INTEGER :: ierr, my_tag
3630 : #endif
3631 :
3632 0 : CALL mp_timeset(routineN, handle)
3633 :
3634 : #if defined(__parallel)
3635 0 : my_tag = 0
3636 0 : IF (PRESENT(tag)) my_tag = tag
3637 :
3638 : CALL mpi_irecv(msgout, 1, ${mpi_type1}$, source, my_tag, &
3639 0 : comm%handle, recv_request%handle, ierr)
3640 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routineN)
3641 :
3642 : CALL mpi_isend(msgin, 1, ${mpi_type1}$, dest, my_tag, &
3643 0 : comm%handle, send_request%handle, ierr)
3644 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
3645 :
3646 0 : CALL add_perf(perf_id=8, count=1, msg_size=2*${bytes1}$)
3647 : #else
3648 : MARK_USED(dest)
3649 : MARK_USED(source)
3650 : MARK_USED(comm)
3651 : MARK_USED(tag)
3652 : send_request = mp_request_null
3653 : recv_request = mp_request_null
3654 : msgout = msgin
3655 : #endif
3656 0 : CALL mp_timestop(handle)
3657 0 : END SUBROUTINE mp_isendrecv_${nametype1}$
3658 :
3659 : ! **************************************************************************************************
3660 : !> \brief Non-blocking send and receive of a vector
3661 : !> \param[in] msgin Vector data to send
3662 : !> \param[in] dest Which process to send to
3663 : !> \param[out] msgout Receive data into this pointer
3664 : !> \param[in] source Process to receive from
3665 : !> \param[in] comm Message passing environment identifier
3666 : !> \param[out] send_request Request handle for the send
3667 : !> \param[out] recv_request Request handle for the receive
3668 : !> \param[in] tag (optional) tag to differentiate requests
3669 : !> \par Implementation
3670 : !> Calls mpi_isend and mpi_irecv.
3671 : !> \par History
3672 : !> 11.2004 created [Joost VandeVondele]
3673 : !> \note
3674 : !> arrays can be pointers or assumed shape, but they must be contiguous!
3675 : ! **************************************************************************************************
3676 928822 : SUBROUTINE mp_isendrecv_${nametype1}$v(msgin, dest, msgout, source, comm, send_request, &
3677 : recv_request, tag)
3678 : ${type1}$, DIMENSION(:), INTENT(IN) :: msgin
3679 : INTEGER, INTENT(IN) :: dest
3680 : ${type1}$, DIMENSION(:), INTENT(INOUT) :: msgout
3681 : INTEGER, INTENT(IN) :: source
3682 : CLASS(mp_comm_type), INTENT(IN) :: comm
3683 : TYPE(mp_request_type), INTENT(out) :: send_request, recv_request
3684 : INTEGER, INTENT(in), OPTIONAL :: tag
3685 :
3686 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isendrecv_${nametype1}$v'
3687 :
3688 : INTEGER :: handle
3689 : #if defined(__parallel)
3690 : INTEGER :: ierr, msglen, my_tag
3691 : ${type1}$ :: foo
3692 : #endif
3693 :
3694 928822 : CALL mp_timeset(routineN, handle)
3695 :
3696 : #if defined(__parallel)
3697 : #if !defined(__GNUC__) || __GNUC__ >= 9
3698 928822 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
3699 928822 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
3700 : #endif
3701 :
3702 928822 : my_tag = 0
3703 928822 : IF (PRESENT(tag)) my_tag = tag
3704 :
3705 928822 : msglen = SIZE(msgout, 1)
3706 928822 : IF (msglen > 0) THEN
3707 : CALL mpi_irecv(msgout(1), msglen, ${mpi_type1}$, source, my_tag, &
3708 928822 : comm%handle, recv_request%handle, ierr)
3709 : ELSE
3710 : CALL mpi_irecv(foo, msglen, ${mpi_type1}$, source, my_tag, &
3711 0 : comm%handle, recv_request%handle, ierr)
3712 : END IF
3713 928822 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routineN)
3714 :
3715 928822 : msglen = SIZE(msgin, 1)
3716 928822 : IF (msglen > 0) THEN
3717 : CALL mpi_isend(msgin(1), msglen, ${mpi_type1}$, dest, my_tag, &
3718 928822 : comm%handle, send_request%handle, ierr)
3719 : ELSE
3720 : CALL mpi_isend(foo, msglen, ${mpi_type1}$, dest, my_tag, &
3721 0 : comm%handle, send_request%handle, ierr)
3722 : END IF
3723 928822 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
3724 :
3725 928822 : msglen = (msglen + SIZE(msgout, 1) + 1)/2
3726 928822 : CALL add_perf(perf_id=8, count=1, msg_size=msglen*${bytes1}$)
3727 : #else
3728 : MARK_USED(dest)
3729 : MARK_USED(source)
3730 : MARK_USED(comm)
3731 : MARK_USED(tag)
3732 : send_request = mp_request_null
3733 : recv_request = mp_request_null
3734 : msgout = msgin
3735 : #endif
3736 928822 : CALL mp_timestop(handle)
3737 928822 : END SUBROUTINE mp_isendrecv_${nametype1}$v
3738 :
3739 : ! **************************************************************************************************
3740 : !> \brief Non-blocking send of vector data
3741 : !> \param msgin ...
3742 : !> \param dest ...
3743 : !> \param comm ...
3744 : !> \param request ...
3745 : !> \param tag ...
3746 : !> \par History
3747 : !> 08.2003 created [f&j]
3748 : !> \note see mp_isendrecv_${nametype1}$v
3749 : !> \note
3750 : !> arrays can be pointers or assumed shape, but they must be contiguous!
3751 : ! **************************************************************************************************
3752 1151159 : SUBROUTINE mp_isend_${nametype1}$v(msgin, dest, comm, request, tag)
3753 : ${type1}$, DIMENSION(:), INTENT(IN) :: msgin
3754 : INTEGER, INTENT(IN) :: dest
3755 : CLASS(mp_comm_type), INTENT(IN) :: comm
3756 : TYPE(mp_request_type), INTENT(out) :: request
3757 : INTEGER, INTENT(in), OPTIONAL :: tag
3758 :
3759 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_${nametype1}$v'
3760 :
3761 : INTEGER :: handle, ierr
3762 : #if defined(__parallel)
3763 : INTEGER :: msglen, my_tag
3764 : ${type1}$ :: foo(1)
3765 : #endif
3766 :
3767 1151159 : CALL mp_timeset(routineN, handle)
3768 :
3769 : #if defined(__parallel)
3770 : #if !defined(__GNUC__) || __GNUC__ >= 9
3771 1151159 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
3772 : #endif
3773 1151159 : my_tag = 0
3774 1151159 : IF (PRESENT(tag)) my_tag = tag
3775 :
3776 1151159 : msglen = SIZE(msgin)
3777 1151159 : IF (msglen > 0) THEN
3778 : CALL mpi_isend(msgin(1), msglen, ${mpi_type1}$, dest, my_tag, &
3779 1151129 : comm%handle, request%handle, ierr)
3780 : ELSE
3781 : CALL mpi_isend(foo, msglen, ${mpi_type1}$, dest, my_tag, &
3782 30 : comm%handle, request%handle, ierr)
3783 : END IF
3784 1151159 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
3785 :
3786 1151159 : CALL add_perf(perf_id=11, count=1, msg_size=msglen*${bytes1}$)
3787 : #else
3788 : MARK_USED(msgin)
3789 : MARK_USED(dest)
3790 : MARK_USED(comm)
3791 : MARK_USED(request)
3792 : MARK_USED(tag)
3793 : ierr = 1
3794 : request = mp_request_null
3795 : CALL mp_stop(ierr, "mp_isend called in non parallel case")
3796 : #endif
3797 1151159 : CALL mp_timestop(handle)
3798 1151159 : END SUBROUTINE mp_isend_${nametype1}$v
3799 :
3800 : ! **************************************************************************************************
3801 : !> \brief Non-blocking send of matrix data
3802 : !> \param msgin ...
3803 : !> \param dest ...
3804 : !> \param comm ...
3805 : !> \param request ...
3806 : !> \param tag ...
3807 : !> \par History
3808 : !> 2009-11-25 [UB] Made type-generic for templates
3809 : !> \author fawzi
3810 : !> \note see mp_isendrecv_${nametype1}$v
3811 : !> \note see mp_isend_${nametype1}$v
3812 : !> \note
3813 : !> arrays can be pointers or assumed shape, but they must be contiguous!
3814 : ! **************************************************************************************************
3815 783299 : SUBROUTINE mp_isend_${nametype1}$m2(msgin, dest, comm, request, tag)
3816 : ${type1}$, DIMENSION(:, :), INTENT(IN) :: msgin
3817 : INTEGER, INTENT(IN) :: dest
3818 : CLASS(mp_comm_type), INTENT(IN) :: comm
3819 : TYPE(mp_request_type), INTENT(out) :: request
3820 : INTEGER, INTENT(in), OPTIONAL :: tag
3821 :
3822 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_${nametype1}$m2'
3823 :
3824 : INTEGER :: handle, ierr
3825 : #if defined(__parallel)
3826 : INTEGER :: msglen, my_tag
3827 : ${type1}$ :: foo(1)
3828 : #endif
3829 :
3830 783299 : CALL mp_timeset(routineN, handle)
3831 :
3832 : #if defined(__parallel)
3833 : #if !defined(__GNUC__) || __GNUC__ >= 9
3834 2349897 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
3835 : #endif
3836 :
3837 783299 : my_tag = 0
3838 783299 : IF (PRESENT(tag)) my_tag = tag
3839 :
3840 783299 : msglen = SIZE(msgin, 1)*SIZE(msgin, 2)
3841 783299 : IF (msglen > 0) THEN
3842 : CALL mpi_isend(msgin(1, 1), msglen, ${mpi_type1}$, dest, my_tag, &
3843 783299 : comm%handle, request%handle, ierr)
3844 : ELSE
3845 : CALL mpi_isend(foo, msglen, ${mpi_type1}$, dest, my_tag, &
3846 0 : comm%handle, request%handle, ierr)
3847 : END IF
3848 783299 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
3849 :
3850 783299 : CALL add_perf(perf_id=11, count=1, msg_size=msglen*${bytes1}$)
3851 : #else
3852 : MARK_USED(msgin)
3853 : MARK_USED(dest)
3854 : MARK_USED(comm)
3855 : MARK_USED(request)
3856 : MARK_USED(tag)
3857 : ierr = 1
3858 : request = mp_request_null
3859 : CALL mp_stop(ierr, "mp_isend called in non parallel case")
3860 : #endif
3861 783299 : CALL mp_timestop(handle)
3862 783299 : END SUBROUTINE mp_isend_${nametype1}$m2
3863 :
3864 : ! **************************************************************************************************
3865 : !> \brief Non-blocking send of rank-3 data
3866 : !> \param msgin ...
3867 : !> \param dest ...
3868 : !> \param comm ...
3869 : !> \param request ...
3870 : !> \param tag ...
3871 : !> \par History
3872 : !> 9.2008 added _rm3 subroutine [Iain Bethune]
3873 : !> (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
3874 : !> 2009-11-25 [UB] Made type-generic for templates
3875 : !> \author fawzi
3876 : !> \note see mp_isendrecv_${nametype1}$v
3877 : !> \note see mp_isend_${nametype1}$v
3878 : !> \note
3879 : !> arrays can be pointers or assumed shape, but they must be contiguous!
3880 : ! **************************************************************************************************
3881 52685 : SUBROUTINE mp_isend_${nametype1}$m3(msgin, dest, comm, request, tag)
3882 : ${type1}$, DIMENSION(:, :, :), INTENT(IN) :: msgin
3883 : INTEGER, INTENT(IN) :: dest
3884 : CLASS(mp_comm_type), INTENT(IN) :: comm
3885 : TYPE(mp_request_type), INTENT(out) :: request
3886 : INTEGER, INTENT(in), OPTIONAL :: tag
3887 :
3888 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_${nametype1}$m3'
3889 :
3890 : INTEGER :: handle, ierr
3891 : #if defined(__parallel)
3892 : INTEGER :: msglen, my_tag
3893 : ${type1}$ :: foo(1)
3894 : #endif
3895 :
3896 52685 : CALL mp_timeset(routineN, handle)
3897 :
3898 : #if defined(__parallel)
3899 : #if !defined(__GNUC__) || __GNUC__ >= 9
3900 210740 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
3901 : #endif
3902 :
3903 52685 : my_tag = 0
3904 52685 : IF (PRESENT(tag)) my_tag = tag
3905 :
3906 52685 : msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
3907 52685 : IF (msglen > 0) THEN
3908 : CALL mpi_isend(msgin(1, 1, 1), msglen, ${mpi_type1}$, dest, my_tag, &
3909 52685 : comm%handle, request%handle, ierr)
3910 : ELSE
3911 : CALL mpi_isend(foo, msglen, ${mpi_type1}$, dest, my_tag, &
3912 0 : comm%handle, request%handle, ierr)
3913 : END IF
3914 52685 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
3915 :
3916 52685 : CALL add_perf(perf_id=11, count=1, msg_size=msglen*${bytes1}$)
3917 : #else
3918 : MARK_USED(msgin)
3919 : MARK_USED(dest)
3920 : MARK_USED(comm)
3921 : MARK_USED(request)
3922 : MARK_USED(tag)
3923 : ierr = 1
3924 : request = mp_request_null
3925 : CALL mp_stop(ierr, "mp_isend called in non parallel case")
3926 : #endif
3927 52685 : CALL mp_timestop(handle)
3928 52685 : END SUBROUTINE mp_isend_${nametype1}$m3
3929 :
3930 : ! **************************************************************************************************
3931 : !> \brief Non-blocking send of rank-4 data
3932 : !> \param msgin the input message
3933 : !> \param dest the destination processor
3934 : !> \param comm the communicator object
3935 : !> \param request the communication request id
3936 : !> \param tag the message tag
3937 : !> \par History
3938 : !> 2.2016 added _${nametype1}$m4 subroutine [Nico Holmberg]
3939 : !> \author fawzi
3940 : !> \note see mp_isend_${nametype1}$v
3941 : !> \note
3942 : !> arrays can be pointers or assumed shape, but they must be contiguous!
3943 : ! **************************************************************************************************
3944 56 : SUBROUTINE mp_isend_${nametype1}$m4(msgin, dest, comm, request, tag)
3945 : ${type1}$, DIMENSION(:, :, :, :), INTENT(IN) :: msgin
3946 : INTEGER, INTENT(IN) :: dest
3947 : CLASS(mp_comm_type), INTENT(IN) :: comm
3948 : TYPE(mp_request_type), INTENT(out) :: request
3949 : INTEGER, INTENT(in), OPTIONAL :: tag
3950 :
3951 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_${nametype1}$m4'
3952 :
3953 : INTEGER :: handle, ierr
3954 : #if defined(__parallel)
3955 : INTEGER :: msglen, my_tag
3956 : ${type1}$ :: foo(1)
3957 : #endif
3958 :
3959 56 : CALL mp_timeset(routineN, handle)
3960 :
3961 : #if defined(__parallel)
3962 : #if !defined(__GNUC__) || __GNUC__ >= 9
3963 280 : CPASSERT(IS_CONTIGUOUS(msgin) .OR. SIZE(msgin) == 0)
3964 : #endif
3965 :
3966 56 : my_tag = 0
3967 56 : IF (PRESENT(tag)) my_tag = tag
3968 :
3969 56 : msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)*SIZE(msgin, 4)
3970 56 : IF (msglen > 0) THEN
3971 : CALL mpi_isend(msgin(1, 1, 1, 1), msglen, ${mpi_type1}$, dest, my_tag, &
3972 56 : comm%handle, request%handle, ierr)
3973 : ELSE
3974 : CALL mpi_isend(foo, msglen, ${mpi_type1}$, dest, my_tag, &
3975 0 : comm%handle, request%handle, ierr)
3976 : END IF
3977 56 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
3978 :
3979 56 : CALL add_perf(perf_id=11, count=1, msg_size=msglen*${bytes1}$)
3980 : #else
3981 : MARK_USED(msgin)
3982 : MARK_USED(dest)
3983 : MARK_USED(comm)
3984 : MARK_USED(request)
3985 : MARK_USED(tag)
3986 : ierr = 1
3987 : request = mp_request_null
3988 : CALL mp_stop(ierr, "mp_isend called in non parallel case")
3989 : #endif
3990 56 : CALL mp_timestop(handle)
3991 56 : END SUBROUTINE mp_isend_${nametype1}$m4
3992 :
3993 : ! **************************************************************************************************
3994 : !> \brief Non-blocking receive of vector data
3995 : !> \param msgout ...
3996 : !> \param source ...
3997 : !> \param comm ...
3998 : !> \param request ...
3999 : !> \param tag ...
4000 : !> \par History
4001 : !> 08.2003 created [f&j]
4002 : !> 2009-11-25 [UB] Made type-generic for templates
4003 : !> \note see mp_isendrecv_${nametype1}$v
4004 : !> \note
4005 : !> arrays can be pointers or assumed shape, but they must be contiguous!
4006 : ! **************************************************************************************************
4007 1151179 : SUBROUTINE mp_irecv_${nametype1}$v(msgout, source, comm, request, tag)
4008 : ${type1}$, DIMENSION(:), INTENT(INOUT) :: msgout
4009 : INTEGER, INTENT(IN) :: source
4010 : CLASS(mp_comm_type), INTENT(IN) :: comm
4011 : TYPE(mp_request_type), INTENT(out) :: request
4012 : INTEGER, INTENT(in), OPTIONAL :: tag
4013 :
4014 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_${nametype1}$v'
4015 :
4016 : INTEGER :: handle
4017 : #if defined(__parallel)
4018 : INTEGER :: ierr, msglen, my_tag
4019 : ${type1}$ :: foo(1)
4020 : #endif
4021 :
4022 1151179 : CALL mp_timeset(routineN, handle)
4023 :
4024 : #if defined(__parallel)
4025 : #if !defined(__GNUC__) || __GNUC__ >= 9
4026 1151179 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
4027 : #endif
4028 :
4029 1151179 : my_tag = 0
4030 1151179 : IF (PRESENT(tag)) my_tag = tag
4031 :
4032 1151179 : msglen = SIZE(msgout)
4033 1151179 : IF (msglen > 0) THEN
4034 : CALL mpi_irecv(msgout(1), msglen, ${mpi_type1}$, source, my_tag, &
4035 1151134 : comm%handle, request%handle, ierr)
4036 : ELSE
4037 : CALL mpi_irecv(foo, msglen, ${mpi_type1}$, source, my_tag, &
4038 45 : comm%handle, request%handle, ierr)
4039 : END IF
4040 1151179 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routineN)
4041 :
4042 1151179 : CALL add_perf(perf_id=12, count=1, msg_size=msglen*${bytes1}$)
4043 : #else
4044 : CPABORT("mp_irecv called in non parallel case")
4045 : MARK_USED(msgout)
4046 : MARK_USED(source)
4047 : MARK_USED(comm)
4048 : MARK_USED(tag)
4049 : request = mp_request_null
4050 : #endif
4051 1151179 : CALL mp_timestop(handle)
4052 1151179 : END SUBROUTINE mp_irecv_${nametype1}$v
4053 :
4054 : ! **************************************************************************************************
4055 : !> \brief Non-blocking receive of matrix data
4056 : !> \param msgout ...
4057 : !> \param source ...
4058 : !> \param comm ...
4059 : !> \param request ...
4060 : !> \param tag ...
4061 : !> \par History
4062 : !> 2009-11-25 [UB] Made type-generic for templates
4063 : !> \author fawzi
4064 : !> \note see mp_isendrecv_${nametype1}$v
4065 : !> \note see mp_irecv_${nametype1}$v
4066 : !> \note
4067 : !> arrays can be pointers or assumed shape, but they must be contiguous!
4068 : ! **************************************************************************************************
4069 783299 : SUBROUTINE mp_irecv_${nametype1}$m2(msgout, source, comm, request, tag)
4070 : ${type1}$, DIMENSION(:, :), INTENT(INOUT) :: msgout
4071 : INTEGER, INTENT(IN) :: source
4072 : CLASS(mp_comm_type), INTENT(IN) :: comm
4073 : TYPE(mp_request_type), INTENT(out) :: request
4074 : INTEGER, INTENT(in), OPTIONAL :: tag
4075 :
4076 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_${nametype1}$m2'
4077 :
4078 : INTEGER :: handle
4079 : #if defined(__parallel)
4080 : INTEGER :: ierr, msglen, my_tag
4081 : ${type1}$ :: foo(1)
4082 : #endif
4083 :
4084 783299 : CALL mp_timeset(routineN, handle)
4085 :
4086 : #if defined(__parallel)
4087 : #if !defined(__GNUC__) || __GNUC__ >= 9
4088 2349897 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
4089 : #endif
4090 :
4091 783299 : my_tag = 0
4092 783299 : IF (PRESENT(tag)) my_tag = tag
4093 :
4094 783299 : msglen = SIZE(msgout, 1)*SIZE(msgout, 2)
4095 783299 : IF (msglen > 0) THEN
4096 : CALL mpi_irecv(msgout(1, 1), msglen, ${mpi_type1}$, source, my_tag, &
4097 783299 : comm%handle, request%handle, ierr)
4098 : ELSE
4099 : CALL mpi_irecv(foo, msglen, ${mpi_type1}$, source, my_tag, &
4100 0 : comm%handle, request%handle, ierr)
4101 : END IF
4102 783299 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routineN)
4103 :
4104 783299 : CALL add_perf(perf_id=12, count=1, msg_size=msglen*${bytes1}$)
4105 : #else
4106 : MARK_USED(msgout)
4107 : MARK_USED(source)
4108 : MARK_USED(comm)
4109 : MARK_USED(tag)
4110 : request = mp_request_null
4111 : CPABORT("mp_irecv called in non parallel case")
4112 : #endif
4113 783299 : CALL mp_timestop(handle)
4114 783299 : END SUBROUTINE mp_irecv_${nametype1}$m2
4115 :
4116 : ! **************************************************************************************************
4117 : !> \brief Non-blocking send of rank-3 data
4118 : !> \param msgout ...
4119 : !> \param source ...
4120 : !> \param comm ...
4121 : !> \param request ...
4122 : !> \param tag ...
4123 : !> \par History
4124 : !> 9.2008 added _rm3 subroutine [Iain Bethune] (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
4125 : !> 2009-11-25 [UB] Made type-generic for templates
4126 : !> \author fawzi
4127 : !> \note see mp_isendrecv_${nametype1}$v
4128 : !> \note see mp_irecv_${nametype1}$v
4129 : !> \note
4130 : !> arrays can be pointers or assumed shape, but they must be contiguous!
4131 : ! **************************************************************************************************
4132 52685 : SUBROUTINE mp_irecv_${nametype1}$m3(msgout, source, comm, request, tag)
4133 : ${type1}$, DIMENSION(:, :, :), INTENT(INOUT) :: msgout
4134 : INTEGER, INTENT(IN) :: source
4135 : CLASS(mp_comm_type), INTENT(IN) :: comm
4136 : TYPE(mp_request_type), INTENT(out) :: request
4137 : INTEGER, INTENT(in), OPTIONAL :: tag
4138 :
4139 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_${nametype1}$m3'
4140 :
4141 : INTEGER :: handle
4142 : #if defined(__parallel)
4143 : INTEGER :: ierr, msglen, my_tag
4144 : ${type1}$ :: foo(1)
4145 : #endif
4146 :
4147 52685 : CALL mp_timeset(routineN, handle)
4148 :
4149 : #if defined(__parallel)
4150 : #if !defined(__GNUC__) || __GNUC__ >= 9
4151 210740 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
4152 : #endif
4153 :
4154 52685 : my_tag = 0
4155 52685 : IF (PRESENT(tag)) my_tag = tag
4156 :
4157 52685 : msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
4158 52685 : IF (msglen > 0) THEN
4159 : CALL mpi_irecv(msgout(1, 1, 1), msglen, ${mpi_type1}$, source, my_tag, &
4160 52685 : comm%handle, request%handle, ierr)
4161 : ELSE
4162 : CALL mpi_irecv(foo, msglen, ${mpi_type1}$, source, my_tag, &
4163 0 : comm%handle, request%handle, ierr)
4164 : END IF
4165 52685 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routineN)
4166 :
4167 52685 : CALL add_perf(perf_id=12, count=1, msg_size=msglen*${bytes1}$)
4168 : #else
4169 : MARK_USED(msgout)
4170 : MARK_USED(source)
4171 : MARK_USED(comm)
4172 : MARK_USED(tag)
4173 : request = mp_request_null
4174 : CPABORT("mp_irecv called in non parallel case")
4175 : #endif
4176 52685 : CALL mp_timestop(handle)
4177 52685 : END SUBROUTINE mp_irecv_${nametype1}$m3
4178 :
4179 : ! **************************************************************************************************
4180 : !> \brief Non-blocking receive of rank-4 data
4181 : !> \param msgout the output message
4182 : !> \param source the source processor
4183 : !> \param comm the communicator object
4184 : !> \param request the communication request id
4185 : !> \param tag the message tag
4186 : !> \par History
4187 : !> 2.2016 added _${nametype1}$m4 subroutine [Nico Holmberg]
4188 : !> \author fawzi
4189 : !> \note see mp_irecv_${nametype1}$v
4190 : !> \note
4191 : !> arrays can be pointers or assumed shape, but they must be contiguous!
4192 : ! **************************************************************************************************
4193 56 : SUBROUTINE mp_irecv_${nametype1}$m4(msgout, source, comm, request, tag)
4194 : ${type1}$, DIMENSION(:, :, :, :), INTENT(INOUT) :: msgout
4195 : INTEGER, INTENT(IN) :: source
4196 : CLASS(mp_comm_type), INTENT(IN) :: comm
4197 : TYPE(mp_request_type), INTENT(out) :: request
4198 : INTEGER, INTENT(in), OPTIONAL :: tag
4199 :
4200 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_${nametype1}$m4'
4201 :
4202 : INTEGER :: handle
4203 : #if defined(__parallel)
4204 : INTEGER :: ierr, msglen, my_tag
4205 : ${type1}$ :: foo(1)
4206 : #endif
4207 :
4208 56 : CALL mp_timeset(routineN, handle)
4209 :
4210 : #if defined(__parallel)
4211 : #if !defined(__GNUC__) || __GNUC__ >= 9
4212 280 : CPASSERT(IS_CONTIGUOUS(msgout) .OR. SIZE(msgout) == 0)
4213 : #endif
4214 :
4215 56 : my_tag = 0
4216 56 : IF (PRESENT(tag)) my_tag = tag
4217 :
4218 56 : msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)*SIZE(msgout, 4)
4219 56 : IF (msglen > 0) THEN
4220 : CALL mpi_irecv(msgout(1, 1, 1, 1), msglen, ${mpi_type1}$, source, my_tag, &
4221 56 : comm%handle, request%handle, ierr)
4222 : ELSE
4223 : CALL mpi_irecv(foo, msglen, ${mpi_type1}$, source, my_tag, &
4224 0 : comm%handle, request%handle, ierr)
4225 : END IF
4226 56 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routineN)
4227 :
4228 56 : CALL add_perf(perf_id=12, count=1, msg_size=msglen*${bytes1}$)
4229 : #else
4230 : MARK_USED(msgout)
4231 : MARK_USED(source)
4232 : MARK_USED(comm)
4233 : MARK_USED(tag)
4234 : request = mp_request_null
4235 : CPABORT("mp_irecv called in non parallel case")
4236 : #endif
4237 56 : CALL mp_timestop(handle)
4238 56 : END SUBROUTINE mp_irecv_${nametype1}$m4
4239 :
4240 : ! **************************************************************************************************
4241 : !> \brief Window initialization function for vector data
4242 : !> \param base ...
4243 : !> \param comm ...
4244 : !> \param win ...
4245 : !> \par History
4246 : !> 02.2015 created [Alfio Lazzaro]
4247 : !> \note
4248 : !> arrays can be pointers or assumed shape, but they must be contiguous!
4249 : ! **************************************************************************************************
4250 0 : SUBROUTINE mp_win_create_${nametype1}$v(base, comm, win)
4251 : ${type1}$, DIMENSION(:), INTENT(INOUT), CONTIGUOUS :: base
4252 : TYPE(mp_comm_type), INTENT(IN) :: comm
4253 : CLASS(mp_win_type), INTENT(INOUT) :: win
4254 :
4255 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_create_${nametype1}$v'
4256 :
4257 : INTEGER :: handle
4258 : #if defined(__parallel)
4259 : INTEGER :: ierr
4260 : INTEGER(kind=mpi_address_kind) :: len
4261 : ${type1}$ :: foo(1)
4262 : #endif
4263 :
4264 0 : CALL mp_timeset(routineN, handle)
4265 :
4266 : #if defined(__parallel)
4267 :
4268 0 : len = SIZE(base)*${bytes1}$
4269 0 : IF (len > 0) THEN
4270 0 : CALL mpi_win_create(base(1), len, ${bytes1}$, MPI_INFO_NULL, comm%handle, win%handle, ierr)
4271 : ELSE
4272 0 : CALL mpi_win_create(foo, len, ${bytes1}$, MPI_INFO_NULL, comm%handle, win%handle, ierr)
4273 : END IF
4274 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_create @ "//routineN)
4275 :
4276 0 : CALL add_perf(perf_id=20, count=1)
4277 : #else
4278 : MARK_USED(base)
4279 : MARK_USED(comm)
4280 : win%handle = mp_win_null_handle
4281 : #endif
4282 0 : CALL mp_timestop(handle)
4283 0 : END SUBROUTINE mp_win_create_${nametype1}$v
4284 :
4285 : ! **************************************************************************************************
4286 : !> \brief Single-sided get function for vector data
4287 : !> \param base ...
4288 : !> \param comm ...
4289 : !> \param win ...
4290 : !> \par History
4291 : !> 02.2015 created [Alfio Lazzaro]
4292 : !> \note
4293 : !> arrays can be pointers or assumed shape, but they must be contiguous!
4294 : ! **************************************************************************************************
4295 0 : SUBROUTINE mp_rget_${nametype1}$v(base, source, win, win_data, myproc, disp, request, &
4296 : origin_datatype, target_datatype)
4297 : ${type1}$, DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: base
4298 : INTEGER, INTENT(IN) :: source
4299 : CLASS(mp_win_type), INTENT(IN) :: win
4300 : ${type1}$, DIMENSION(:), INTENT(IN) :: win_data
4301 : INTEGER, INTENT(IN), OPTIONAL :: myproc, disp
4302 : TYPE(mp_request_type), INTENT(OUT) :: request
4303 : TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype
4304 :
4305 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_rget_${nametype1}$v'
4306 :
4307 : INTEGER :: handle
4308 : #if defined(__parallel)
4309 : INTEGER :: ierr, len, &
4310 : origin_len, target_len
4311 : LOGICAL :: do_local_copy
4312 : INTEGER(kind=mpi_address_kind) :: disp_aint
4313 : MPI_DATA_TYPE :: handle_origin_datatype, handle_target_datatype
4314 : #endif
4315 :
4316 0 : CALL mp_timeset(routineN, handle)
4317 :
4318 : #if defined(__parallel)
4319 0 : len = SIZE(base)
4320 0 : disp_aint = 0
4321 0 : IF (PRESENT(disp)) THEN
4322 0 : disp_aint = INT(disp, KIND=mpi_address_kind)
4323 : END IF
4324 0 : handle_origin_datatype = ${mpi_type1}$
4325 0 : origin_len = len
4326 0 : IF (PRESENT(origin_datatype)) THEN
4327 0 : handle_origin_datatype = origin_datatype%type_handle
4328 0 : origin_len = 1
4329 : END IF
4330 0 : handle_target_datatype = ${mpi_type1}$
4331 0 : target_len = len
4332 0 : IF (PRESENT(target_datatype)) THEN
4333 0 : handle_target_datatype = target_datatype%type_handle
4334 0 : target_len = 1
4335 : END IF
4336 0 : IF (len > 0) THEN
4337 0 : do_local_copy = .FALSE.
4338 0 : IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
4339 0 : IF (myproc .EQ. source) do_local_copy = .TRUE.
4340 : END IF
4341 : IF (do_local_copy) THEN
4342 0 : !$OMP PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
4343 : base(:) = win_data(disp_aint + 1:disp_aint + len)
4344 : !$OMP END PARALLEL WORKSHARE
4345 0 : request = mp_request_null
4346 0 : ierr = 0
4347 : ELSE
4348 : CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
4349 0 : target_len, handle_target_datatype, win%handle, request%handle, ierr)
4350 : END IF
4351 : ELSE
4352 0 : request = mp_request_null
4353 0 : ierr = 0
4354 : END IF
4355 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routineN)
4356 :
4357 0 : CALL add_perf(perf_id=25, count=1, msg_size=SIZE(base)*${bytes1}$)
4358 : #else
4359 : MARK_USED(source)
4360 : MARK_USED(win)
4361 : MARK_USED(myproc)
4362 : MARK_USED(origin_datatype)
4363 : MARK_USED(target_datatype)
4364 :
4365 : request = mp_request_null
4366 : !
4367 : IF (PRESENT(disp)) THEN
4368 : base(:) = win_data(disp + 1:disp + SIZE(base))
4369 : ELSE
4370 : base(:) = win_data(:SIZE(base))
4371 : END IF
4372 :
4373 : #endif
4374 0 : CALL mp_timestop(handle)
4375 0 : END SUBROUTINE mp_rget_${nametype1}$v
4376 :
4377 : ! **************************************************************************************************
4378 : !> \brief ...
4379 : !> \param count ...
4380 : !> \param lengths ...
4381 : !> \param displs ...
4382 : !> \return ...
4383 : ! ***************************************************************************
4384 0 : FUNCTION mp_type_indexed_make_${nametype1}$ (count, lengths, displs) &
4385 : RESULT(type_descriptor)
4386 : INTEGER, INTENT(IN) :: count
4387 : INTEGER, DIMENSION(1:count), INTENT(IN), TARGET :: lengths, displs
4388 : TYPE(mp_type_descriptor_type) :: type_descriptor
4389 :
4390 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_type_indexed_make_${nametype1}$'
4391 :
4392 : INTEGER :: handle
4393 : #if defined(__parallel)
4394 : INTEGER :: ierr
4395 : #endif
4396 :
4397 0 : CALL mp_timeset(routineN, handle)
4398 :
4399 : #if defined(__parallel)
4400 : CALL mpi_type_indexed(count, lengths, displs, ${mpi_type1}$, &
4401 0 : type_descriptor%type_handle, ierr)
4402 0 : IF (ierr /= 0) &
4403 0 : CPABORT("MPI_Type_Indexed @ "//routineN)
4404 0 : CALL mpi_type_commit(type_descriptor%type_handle, ierr)
4405 0 : IF (ierr /= 0) &
4406 0 : CPABORT("MPI_Type_commit @ "//routineN)
4407 : #else
4408 : type_descriptor%type_handle = ${handle1}$
4409 : #endif
4410 0 : type_descriptor%length = count
4411 0 : NULLIFY (type_descriptor%subtype)
4412 0 : type_descriptor%vector_descriptor(1:2) = 1
4413 0 : type_descriptor%has_indexing = .TRUE.
4414 0 : type_descriptor%index_descriptor%index => lengths
4415 0 : type_descriptor%index_descriptor%chunks => displs
4416 :
4417 0 : CALL mp_timestop(handle)
4418 :
4419 0 : END FUNCTION mp_type_indexed_make_${nametype1}$
4420 :
4421 : ! **************************************************************************************************
4422 : !> \brief Allocates special parallel memory
4423 : !> \param[in] DATA pointer to integer array to allocate
4424 : !> \param[in] len number of integers to allocate
4425 : !> \param[out] stat (optional) allocation status result
4426 : !> \author UB
4427 : ! **************************************************************************************************
4428 0 : SUBROUTINE mp_allocate_${nametype1}$ (DATA, len, stat)
4429 : ${type1}$, CONTIGUOUS, DIMENSION(:), POINTER :: DATA
4430 : INTEGER, INTENT(IN) :: len
4431 : INTEGER, INTENT(OUT), OPTIONAL :: stat
4432 :
4433 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_allocate_${nametype1}$'
4434 :
4435 : INTEGER :: handle, ierr
4436 :
4437 0 : CALL mp_timeset(routineN, handle)
4438 :
4439 : #if defined(__parallel)
4440 0 : NULLIFY (DATA)
4441 0 : CALL mp_alloc_mem(DATA, len, stat=ierr)
4442 0 : IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
4443 0 : CALL mp_stop(ierr, "mpi_alloc_mem @ "//routineN)
4444 0 : CALL add_perf(perf_id=15, count=1)
4445 : #else
4446 : ALLOCATE (DATA(len), stat=ierr)
4447 : IF (ierr /= 0 .AND. .NOT. PRESENT(stat)) &
4448 : CALL mp_stop(ierr, "ALLOCATE @ "//routineN)
4449 : #endif
4450 0 : IF (PRESENT(stat)) stat = ierr
4451 0 : CALL mp_timestop(handle)
4452 0 : END SUBROUTINE mp_allocate_${nametype1}$
4453 :
4454 : ! **************************************************************************************************
4455 : !> \brief Deallocates special parallel memory
4456 : !> \param[in] DATA pointer to special memory to deallocate
4457 : !> \param stat ...
4458 : !> \author UB
4459 : ! **************************************************************************************************
4460 0 : SUBROUTINE mp_deallocate_${nametype1}$ (DATA, stat)
4461 : ${type1}$, CONTIGUOUS, DIMENSION(:), POINTER :: DATA
4462 : INTEGER, INTENT(OUT), OPTIONAL :: stat
4463 :
4464 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_deallocate_${nametype1}$'
4465 :
4466 : INTEGER :: handle
4467 : #if defined(__parallel)
4468 : INTEGER :: ierr
4469 : #endif
4470 :
4471 0 : CALL mp_timeset(routineN, handle)
4472 :
4473 : #if defined(__parallel)
4474 0 : CALL mp_free_mem(DATA, ierr)
4475 0 : IF (PRESENT(stat)) THEN
4476 0 : stat = ierr
4477 : ELSE
4478 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_free_mem @ "//routineN)
4479 : END IF
4480 0 : NULLIFY (DATA)
4481 0 : CALL add_perf(perf_id=15, count=1)
4482 : #else
4483 : DEALLOCATE (DATA)
4484 : IF (PRESENT(stat)) stat = 0
4485 : #endif
4486 0 : CALL mp_timestop(handle)
4487 0 : END SUBROUTINE mp_deallocate_${nametype1}$
4488 :
4489 : ! **************************************************************************************************
4490 : !> \brief (parallel) Blocking individual file write using explicit offsets
4491 : !> (serial) Unformatted stream write
4492 : !> \param[in] fh file handle (file storage unit)
4493 : !> \param[in] offset file offset (position)
4494 : !> \param[in] msg data to be written to the file
4495 : !> \param msglen ...
4496 : !> \par MPI-I/O mapping mpi_file_write_at
4497 : !> \par STREAM-I/O mapping WRITE
4498 : !> \param[in](optional) msglen number of the elements of data
4499 : ! **************************************************************************************************
4500 0 : SUBROUTINE mp_file_write_at_${nametype1}$v(fh, offset, msg, msglen)
4501 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:)
4502 : CLASS(mp_file_type), INTENT(IN) :: fh
4503 : INTEGER, INTENT(IN), OPTIONAL :: msglen
4504 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4505 :
4506 : INTEGER :: msg_len
4507 : #if defined(__parallel)
4508 : INTEGER :: ierr
4509 : #endif
4510 :
4511 0 : msg_len = SIZE(msg)
4512 0 : IF (PRESENT(msglen)) msg_len = msglen
4513 : #if defined(__parallel)
4514 0 : CALL MPI_FILE_WRITE_AT(fh%handle, offset, msg, msg_len, ${mpi_type1}$, MPI_STATUS_IGNORE, ierr)
4515 0 : IF (ierr .NE. 0) &
4516 0 : CPABORT("mpi_file_write_at_${nametype1}$v @ mp_file_write_at_${nametype1}$v")
4517 : #else
4518 : WRITE (UNIT=fh%handle, POS=offset + 1) msg(1:msg_len)
4519 : #endif
4520 0 : END SUBROUTINE mp_file_write_at_${nametype1}$v
4521 :
4522 : ! **************************************************************************************************
4523 : !> \brief ...
4524 : !> \param fh ...
4525 : !> \param offset ...
4526 : !> \param msg ...
4527 : ! **************************************************************************************************
4528 0 : SUBROUTINE mp_file_write_at_${nametype1}$ (fh, offset, msg)
4529 : ${type1}$, INTENT(IN) :: msg
4530 : CLASS(mp_file_type), INTENT(IN) :: fh
4531 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4532 :
4533 : #if defined(__parallel)
4534 : INTEGER :: ierr
4535 :
4536 : ierr = 0
4537 0 : CALL MPI_FILE_WRITE_AT(fh%handle, offset, msg, 1, ${mpi_type1}$, MPI_STATUS_IGNORE, ierr)
4538 0 : IF (ierr .NE. 0) &
4539 0 : CPABORT("mpi_file_write_at_${nametype1}$ @ mp_file_write_at_${nametype1}$")
4540 : #else
4541 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
4542 : #endif
4543 0 : END SUBROUTINE mp_file_write_at_${nametype1}$
4544 :
4545 : ! **************************************************************************************************
4546 : !> \brief (parallel) Blocking collective file write using explicit offsets
4547 : !> (serial) Unformatted stream write
4548 : !> \param fh ...
4549 : !> \param offset ...
4550 : !> \param msg ...
4551 : !> \param msglen ...
4552 : !> \par MPI-I/O mapping mpi_file_write_at_all
4553 : !> \par STREAM-I/O mapping WRITE
4554 : ! **************************************************************************************************
4555 0 : SUBROUTINE mp_file_write_at_all_${nametype1}$v(fh, offset, msg, msglen)
4556 : ${type1}$, CONTIGUOUS, INTENT(IN) :: msg(:)
4557 : CLASS(mp_file_type), INTENT(IN) :: fh
4558 : INTEGER, INTENT(IN), OPTIONAL :: msglen
4559 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4560 :
4561 : INTEGER :: msg_len
4562 : #if defined(__parallel)
4563 : INTEGER :: ierr
4564 : #endif
4565 :
4566 0 : msg_len = SIZE(msg)
4567 0 : IF (PRESENT(msglen)) msg_len = msglen
4568 : #if defined(__parallel)
4569 0 : CALL MPI_FILE_WRITE_AT_ALL(fh%handle, offset, msg, msg_len, ${mpi_type1}$, MPI_STATUS_IGNORE, ierr)
4570 0 : IF (ierr .NE. 0) &
4571 0 : CPABORT("mpi_file_write_at_all_${nametype1}$v @ mp_file_write_at_all_${nametype1}$v")
4572 : #else
4573 : WRITE (UNIT=fh%handle, POS=offset + 1) msg(1:msg_len)
4574 : #endif
4575 0 : END SUBROUTINE mp_file_write_at_all_${nametype1}$v
4576 :
4577 : ! **************************************************************************************************
4578 : !> \brief ...
4579 : !> \param fh ...
4580 : !> \param offset ...
4581 : !> \param msg ...
4582 : ! **************************************************************************************************
4583 0 : SUBROUTINE mp_file_write_at_all_${nametype1}$ (fh, offset, msg)
4584 : ${type1}$, INTENT(IN) :: msg
4585 : CLASS(mp_file_type), INTENT(IN) :: fh
4586 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4587 :
4588 : #if defined(__parallel)
4589 : INTEGER :: ierr
4590 :
4591 : ierr = 0
4592 0 : CALL MPI_FILE_WRITE_AT_ALL(fh%handle, offset, msg, 1, ${mpi_type1}$, MPI_STATUS_IGNORE, ierr)
4593 0 : IF (ierr .NE. 0) &
4594 0 : CPABORT("mpi_file_write_at_all_${nametype1}$ @ mp_file_write_at_all_${nametype1}$")
4595 : #else
4596 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
4597 : #endif
4598 0 : END SUBROUTINE mp_file_write_at_all_${nametype1}$
4599 :
4600 : ! **************************************************************************************************
4601 : !> \brief (parallel) Blocking individual file read using explicit offsets
4602 : !> (serial) Unformatted stream read
4603 : !> \param[in] fh file handle (file storage unit)
4604 : !> \param[in] offset file offset (position)
4605 : !> \param[out] msg data to be read from the file
4606 : !> \param msglen ...
4607 : !> \par MPI-I/O mapping mpi_file_read_at
4608 : !> \par STREAM-I/O mapping READ
4609 : !> \param[in](optional) msglen number of elements of data
4610 : ! **************************************************************************************************
4611 0 : SUBROUTINE mp_file_read_at_${nametype1}$v(fh, offset, msg, msglen)
4612 : ${type1}$, INTENT(OUT), CONTIGUOUS :: msg(:)
4613 : CLASS(mp_file_type), INTENT(IN) :: fh
4614 : INTEGER, INTENT(IN), OPTIONAL :: msglen
4615 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4616 :
4617 : INTEGER :: msg_len
4618 : #if defined(__parallel)
4619 : INTEGER :: ierr
4620 : #endif
4621 :
4622 0 : msg_len = SIZE(msg)
4623 0 : IF (PRESENT(msglen)) msg_len = msglen
4624 : #if defined(__parallel)
4625 0 : CALL MPI_FILE_READ_AT(fh%handle, offset, msg, msg_len, ${mpi_type1}$, MPI_STATUS_IGNORE, ierr)
4626 0 : IF (ierr .NE. 0) &
4627 0 : CPABORT("mpi_file_read_at_${nametype1}$v @ mp_file_read_at_${nametype1}$v")
4628 : #else
4629 : READ (UNIT=fh%handle, POS=offset + 1) msg(1:msg_len)
4630 : #endif
4631 0 : END SUBROUTINE mp_file_read_at_${nametype1}$v
4632 :
4633 : ! **************************************************************************************************
4634 : !> \brief ...
4635 : !> \param fh ...
4636 : !> \param offset ...
4637 : !> \param msg ...
4638 : ! **************************************************************************************************
4639 0 : SUBROUTINE mp_file_read_at_${nametype1}$ (fh, offset, msg)
4640 : ${type1}$, INTENT(OUT) :: msg
4641 : CLASS(mp_file_type), INTENT(IN) :: fh
4642 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4643 :
4644 : #if defined(__parallel)
4645 : INTEGER :: ierr
4646 :
4647 : ierr = 0
4648 0 : CALL MPI_FILE_READ_AT(fh%handle, offset, msg, 1, ${mpi_type1}$, MPI_STATUS_IGNORE, ierr)
4649 0 : IF (ierr .NE. 0) &
4650 0 : CPABORT("mpi_file_read_at_${nametype1}$ @ mp_file_read_at_${nametype1}$")
4651 : #else
4652 : READ (UNIT=fh%handle, POS=offset + 1) msg
4653 : #endif
4654 0 : END SUBROUTINE mp_file_read_at_${nametype1}$
4655 :
4656 : ! **************************************************************************************************
4657 : !> \brief (parallel) Blocking collective file read using explicit offsets
4658 : !> (serial) Unformatted stream read
4659 : !> \param fh ...
4660 : !> \param offset ...
4661 : !> \param msg ...
4662 : !> \param msglen ...
4663 : !> \par MPI-I/O mapping mpi_file_read_at_all
4664 : !> \par STREAM-I/O mapping READ
4665 : ! **************************************************************************************************
4666 0 : SUBROUTINE mp_file_read_at_all_${nametype1}$v(fh, offset, msg, msglen)
4667 : ${type1}$, INTENT(OUT), CONTIGUOUS :: msg(:)
4668 : CLASS(mp_file_type), INTENT(IN) :: fh
4669 : INTEGER, INTENT(IN), OPTIONAL :: msglen
4670 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4671 :
4672 : INTEGER :: msg_len
4673 : #if defined(__parallel)
4674 : INTEGER :: ierr
4675 : #endif
4676 :
4677 0 : msg_len = SIZE(msg)
4678 0 : IF (PRESENT(msglen)) msg_len = msglen
4679 : #if defined(__parallel)
4680 0 : CALL MPI_FILE_READ_AT_ALL(fh%handle, offset, msg, msg_len, ${mpi_type1}$, MPI_STATUS_IGNORE, ierr)
4681 0 : IF (ierr .NE. 0) &
4682 0 : CPABORT("mpi_file_read_at_all_${nametype1}$v @ mp_file_read_at_all_${nametype1}$v")
4683 : #else
4684 : READ (UNIT=fh%handle, POS=offset + 1) msg(1:msg_len)
4685 : #endif
4686 0 : END SUBROUTINE mp_file_read_at_all_${nametype1}$v
4687 :
4688 : ! **************************************************************************************************
4689 : !> \brief ...
4690 : !> \param fh ...
4691 : !> \param offset ...
4692 : !> \param msg ...
4693 : ! **************************************************************************************************
4694 0 : SUBROUTINE mp_file_read_at_all_${nametype1}$ (fh, offset, msg)
4695 : ${type1}$, INTENT(OUT) :: msg
4696 : CLASS(mp_file_type), INTENT(IN) :: fh
4697 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4698 :
4699 : #if defined(__parallel)
4700 : INTEGER :: ierr
4701 :
4702 : ierr = 0
4703 0 : CALL MPI_FILE_READ_AT_ALL(fh%handle, offset, msg, 1, ${mpi_type1}$, MPI_STATUS_IGNORE, ierr)
4704 0 : IF (ierr .NE. 0) &
4705 0 : CPABORT("mpi_file_read_at_all_${nametype1}$ @ mp_file_read_at_all_${nametype1}$")
4706 : #else
4707 : READ (UNIT=fh%handle, POS=offset + 1) msg
4708 : #endif
4709 0 : END SUBROUTINE mp_file_read_at_all_${nametype1}$
4710 :
4711 : ! **************************************************************************************************
4712 : !> \brief ...
4713 : !> \param ptr ...
4714 : !> \param vector_descriptor ...
4715 : !> \param index_descriptor ...
4716 : !> \return ...
4717 : ! **************************************************************************************************
4718 0 : FUNCTION mp_type_make_${nametype1}$ (ptr, &
4719 : vector_descriptor, index_descriptor) &
4720 : RESULT(type_descriptor)
4721 : ${type1}$, DIMENSION(:), TARGET, ASYNCHRONOUS :: ptr
4722 : INTEGER, DIMENSION(2), INTENT(IN), OPTIONAL :: vector_descriptor
4723 : TYPE(mp_indexing_meta_type), INTENT(IN), OPTIONAL :: index_descriptor
4724 : TYPE(mp_type_descriptor_type) :: type_descriptor
4725 :
4726 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_type_make_${nametype1}$'
4727 :
4728 : #if defined(__parallel)
4729 : INTEGER :: ierr
4730 : #if defined(__MPI_F08)
4731 : ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
4732 : EXTERNAL :: mpi_get_address
4733 : #endif
4734 : #endif
4735 :
4736 : NULLIFY (type_descriptor%subtype)
4737 0 : type_descriptor%length = SIZE(ptr)
4738 : #if defined(__parallel)
4739 0 : type_descriptor%type_handle = ${mpi_type1}$
4740 0 : CALL MPI_Get_address(ptr, type_descriptor%base, ierr)
4741 0 : IF (ierr /= 0) &
4742 0 : CPABORT("MPI_Get_address @ "//routineN)
4743 : #else
4744 : type_descriptor%type_handle = ${handle1}$
4745 : #endif
4746 0 : type_descriptor%vector_descriptor(1:2) = 1
4747 0 : type_descriptor%has_indexing = .FALSE.
4748 0 : type_descriptor%data_${nametype1}$ => ptr
4749 0 : IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
4750 0 : CPABORT(routineN//": Vectors and indices NYI")
4751 : END IF
4752 0 : END FUNCTION mp_type_make_${nametype1}$
4753 :
4754 : ! **************************************************************************************************
4755 : !> \brief Allocates an array, using MPI_ALLOC_MEM ... this is hackish
4756 : !> as the Fortran version returns an integer, which we take to be a C_PTR
4757 : !> \param DATA data array to allocate
4758 : !> \param[in] len length (in data elements) of data array allocation
4759 : !> \param[out] stat (optional) allocation status result
4760 : ! **************************************************************************************************
4761 0 : SUBROUTINE mp_alloc_mem_${nametype1}$ (DATA, len, stat)
4762 : ${type1}$, CONTIGUOUS, DIMENSION(:), POINTER :: DATA
4763 : INTEGER, INTENT(IN) :: len
4764 : INTEGER, INTENT(OUT), OPTIONAL :: stat
4765 :
4766 : #if defined(__parallel)
4767 : INTEGER :: size, ierr, length, &
4768 : mp_res
4769 : INTEGER(KIND=MPI_ADDRESS_KIND) :: mp_size
4770 : TYPE(C_PTR) :: mp_baseptr
4771 : MPI_INFO_TYPE :: mp_info
4772 :
4773 0 : length = MAX(len, 1)
4774 0 : CALL MPI_TYPE_SIZE(${mpi_type1}$, size, ierr)
4775 0 : mp_size = INT(length, KIND=MPI_ADDRESS_KIND)*size
4776 0 : IF (mp_size .GT. mp_max_memory_size) THEN
4777 0 : CPABORT("MPI cannot allocate more than 2 GiByte")
4778 : END IF
4779 0 : mp_info = MPI_INFO_NULL
4780 0 : CALL MPI_ALLOC_MEM(mp_size, mp_info, mp_baseptr, mp_res)
4781 0 : CALL C_F_POINTER(mp_baseptr, DATA, (/length/))
4782 0 : IF (PRESENT(stat)) stat = mp_res
4783 : #else
4784 : INTEGER :: length, mystat
4785 : length = MAX(len, 1)
4786 : IF (PRESENT(stat)) THEN
4787 : ALLOCATE (DATA(length), stat=mystat)
4788 : stat = mystat ! show to convention checker that stat is used
4789 : ELSE
4790 : ALLOCATE (DATA(length))
4791 : END IF
4792 : #endif
4793 0 : END SUBROUTINE mp_alloc_mem_${nametype1}$
4794 :
4795 : ! **************************************************************************************************
4796 : !> \brief Deallocates am array, ... this is hackish
4797 : !> as the Fortran version takes an integer, which we hope to get by reference
4798 : !> \param DATA data array to allocate
4799 : !> \param[out] stat (optional) allocation status result
4800 : ! **************************************************************************************************
4801 0 : SUBROUTINE mp_free_mem_${nametype1}$ (DATA, stat)
4802 : ${type1}$, DIMENSION(:), &
4803 : POINTER, ASYNCHRONOUS :: DATA
4804 : INTEGER, INTENT(OUT), OPTIONAL :: stat
4805 :
4806 : #if defined(__parallel)
4807 : INTEGER :: mp_res
4808 0 : CALL MPI_FREE_MEM(DATA, mp_res)
4809 0 : IF (PRESENT(stat)) stat = mp_res
4810 : #else
4811 : DEALLOCATE (DATA)
4812 : IF (PRESENT(stat)) stat = 0
4813 : #endif
4814 0 : END SUBROUTINE mp_free_mem_${nametype1}$
4815 : #:endfor
|
