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