Line data Source code
1 : !-----------------------------------------------------------------------
2 : !
3 : ! Purpose:
4 : !
5 : ! Wrapper routines for the MPI (Message Passing) library for the
6 : ! distributed memory (SPMD) version of the code. Also data with
7 : ! "shorthand" names for the MPI data types.
8 : !
9 : ! Entry points:
10 : ! mpibarrier Calls mpi_barrier
11 : ! mpifinalize Calls mpi_finalize
12 : ! mpipack_size Calls mpi_pack
13 : ! mpipack Calls mpi_pack
14 : ! mpiunpack Calls mpi_unpack
15 : ! mpisendrecv Calls mpi_sendrecv
16 : ! mpiisend Calls mpi_isend
17 : ! mpiirsend Calls mpi_irsend
18 : ! mpiissend Calls mpi_issend
19 : ! mpiirecv Calls mpi_irecv
20 : ! mpiwait Calls mpi_wait
21 : ! mpiwaitall Calls mpi_waitall
22 : ! mpisend Calls mpi_send
23 : ! mpirsend Calls mpi_rsend
24 : ! mpissend Calls mpi_ssend
25 : ! mpirecv Calls mpi_recv
26 : ! mpigather Calls mpi_gather
27 : ! mpigatherv Calls mpi_gatherv
28 : ! mpigathervr4 Calls mpi_gatherv for real*4 data
29 : ! mpigathervint Calls mpi_gatherv for integer data
30 : ! mpisum Calls mpi_sum
31 : ! mpiscatter Calls mpi_scatter
32 : ! mpiscatterv Calls mpi_scatterv
33 : ! mpibcast Calls mpi_bcast
34 : ! mpiallmaxint Calls mpi_allreduce on integer vector with mpi_max operator
35 : ! mpialltoallv Calls mpi_alltoallv
36 : ! mpialltoallint Calls mpi_alltoall for integer data
37 : ! mpiallgatherv Calls mpi_allgatherv
38 : ! mpiallgatherint Calls mpi_allgatherv for integer data
39 : ! mpiwincreate Calls mpi_win_create and mpi_win_fence
40 : !
41 : ! Author: Many
42 : !
43 : !-----------------------------------------------------------------------
44 : !
45 :
46 : !
47 : ! Performance bug work around for Gemini interconnect
48 : !
49 : #ifdef _NO_MPI_RSEND
50 : #define mpi_rsend mpi_send
51 : #define mpi_irsend mpi_isend
52 : #endif
53 :
54 : !
55 : ! Compile these routines only when SPMD is defined
56 : !
57 : #if (defined SPMD)
58 :
59 : !****************************************************************
60 :
61 0 : subroutine mpibarrier (comm)
62 : !
63 : ! MPI barrier, have threads wait until all threads have reached this point
64 : !
65 : use shr_kind_mod, only: r8 => shr_kind_r8
66 : use mpishorthand
67 : use cam_abortutils, only: endrun
68 : use cam_logfile, only: iulog
69 :
70 : implicit none
71 :
72 : integer, intent(in):: comm
73 :
74 : integer ier !MP error code
75 :
76 0 : call mpi_barrier (comm, ier)
77 0 : if (ier.ne.mpi_success) then
78 0 : write(iulog,*)'mpi_barrier failed ier=',ier
79 0 : call endrun
80 : end if
81 :
82 0 : return
83 : end subroutine mpibarrier
84 :
85 : !****************************************************************
86 :
87 0 : subroutine mpifinalize
88 : !
89 : ! End of all MPI communication
90 : !
91 : use shr_kind_mod, only: r8 => shr_kind_r8
92 : use mpishorthand
93 : use cam_abortutils, only: endrun
94 : use cam_logfile, only: iulog
95 :
96 : implicit none
97 :
98 : integer ier !MP error code
99 :
100 0 : call mpi_finalize (ier)
101 0 : if (ier.ne.mpi_success) then
102 0 : write(iulog,*)'mpi_finalize failed ier=',ier
103 0 : call endrun
104 : end if
105 :
106 0 : return
107 : end subroutine mpifinalize
108 :
109 : !****************************************************************
110 :
111 0 : subroutine mpipack_size (incount, datatype, comm, size)
112 : !
113 : ! Returns the size of the packed data
114 : !
115 : use shr_kind_mod, only: r8 => shr_kind_r8
116 : use mpishorthand
117 : use cam_abortutils, only: endrun
118 : use cam_logfile, only: iulog
119 :
120 : implicit none
121 :
122 : integer, intent(in):: incount
123 : integer, intent(in):: datatype
124 : integer, intent(in):: comm
125 : integer, intent(out):: size
126 :
127 : integer ier !MP error code
128 :
129 0 : call mpi_pack_size (incount, datatype, comm, size, ier)
130 0 : if (ier.ne.mpi_success) then
131 0 : write(iulog,*)'mpi_pack_size failed ier=',ier
132 0 : call endrun
133 : end if
134 :
135 0 : return
136 : end subroutine mpipack_size
137 :
138 : !****************************************************************
139 :
140 0 : subroutine mpipack (inbuf, incount, datatype, outbuf, outsize, &
141 : position, comm)
142 : !
143 : ! Pack the data and send it.
144 : !
145 : use shr_kind_mod, only: r8 => shr_kind_r8
146 : use mpishorthand
147 : use cam_abortutils, only: endrun
148 : use cam_logfile, only: iulog
149 :
150 : implicit none
151 :
152 : real(r8), intent(in):: inbuf(*)
153 : real(r8), intent(out):: outbuf(*)
154 : integer, intent(in):: incount
155 : integer, intent(in):: datatype
156 : integer, intent(out):: outsize
157 : integer, intent(inout):: position
158 : integer, intent(in):: comm
159 :
160 : integer ier !MP error code
161 :
162 : call mpi_pack (inbuf, incount, datatype, outbuf, outsize, &
163 0 : position, comm, ier)
164 0 : if (ier.ne.mpi_success) then
165 0 : write(iulog,*)'mpi_pack failed ier=',ier
166 0 : call endrun
167 : end if
168 :
169 0 : return
170 : end subroutine mpipack
171 :
172 : !****************************************************************
173 :
174 0 : subroutine mpiunpack (inbuf, insize, position, outbuf, outcount, &
175 : datatype, comm)
176 : !
177 : ! Un-packs the data from the packed receive buffer
178 : !
179 : use shr_kind_mod, only: r8 => shr_kind_r8
180 : use mpishorthand
181 : use cam_abortutils, only: endrun
182 : use cam_logfile, only: iulog
183 :
184 : implicit none
185 :
186 : real(r8), intent(in):: inbuf(*)
187 : real(r8), intent(out):: outbuf(*)
188 : integer, intent(in):: insize
189 : integer, intent(inout):: position
190 : integer, intent(in):: outcount
191 : integer, intent(in):: datatype
192 : integer, intent(in):: comm
193 :
194 : integer ier !MP error code
195 :
196 : call mpi_unpack (inbuf, insize, position, outbuf, outcount, &
197 0 : datatype, comm, ier)
198 0 : if (ier.ne.mpi_success) then
199 0 : write(iulog,*)'mpi_unpack failed ier=',ier
200 0 : call endrun
201 : end if
202 :
203 0 : return
204 : end subroutine mpiunpack
205 :
206 : !****************************************************************
207 :
208 0 : subroutine mpisendrecv (sendbuf, sendcount, sendtype, dest, sendtag, &
209 : recvbuf, recvcount, recvtype, source,recvtag, &
210 : comm)
211 : !
212 : ! Blocking send and receive.
213 : !
214 : use shr_kind_mod, only: r8 => shr_kind_r8
215 : use mpishorthand
216 : use cam_abortutils, only: endrun
217 : use cam_logfile, only: iulog
218 : #if defined( WRAP_MPI_TIMING )
219 : use perf_mod
220 : #endif
221 :
222 : implicit none
223 :
224 : real(r8), intent(in):: sendbuf(*)
225 : real(r8), intent(out):: recvbuf(*)
226 : integer, intent(in):: sendcount
227 : integer, intent(in):: sendtype
228 : integer, intent(in):: dest
229 : integer, intent(in):: sendtag
230 : integer, intent(in):: recvcount
231 : integer, intent(in):: recvtype
232 : integer, intent(in):: source
233 : integer, intent(in):: recvtag
234 : integer, intent(in):: comm
235 :
236 : integer :: status(MPI_STATUS_SIZE)
237 : integer ier !MP error code
238 :
239 : #if defined( WRAP_MPI_TIMING )
240 : call t_startf ('mpi_sendrecv')
241 : #endif
242 : call mpi_sendrecv (sendbuf, sendcount, sendtype, dest, sendtag, &
243 : recvbuf, recvcount, recvtype, source, recvtag, &
244 0 : comm, status, ier)
245 0 : if (ier.ne.mpi_success) then
246 0 : write(iulog,*)'mpi_sendrecv failed ier=',ier
247 0 : call endrun
248 : end if
249 : !
250 : ! ASSUME nrecv = nsend for stats gathering purposes. This is not actually
251 : ! correct, but its the best we can do since recvcount is a Max number
252 : !
253 0 : nsend = nsend + 1
254 0 : nrecv = nrecv + 1
255 0 : nwsend = nwsend + sendcount
256 0 : nwrecv = nwrecv + sendcount
257 :
258 : #if defined( WRAP_MPI_TIMING )
259 : call t_stopf ('mpi_sendrecv')
260 : #endif
261 :
262 0 : return
263 : end subroutine mpisendrecv
264 :
265 : !****************************************************************
266 :
267 0 : subroutine mpiisend (buf, count, datatype, dest, tag, comm, request)
268 : !
269 : ! Does a non-blocking send.
270 : !
271 : use shr_kind_mod, only: r8 => shr_kind_r8
272 : use mpishorthand
273 : use cam_abortutils, only: endrun
274 : use cam_logfile, only: iulog
275 : #if defined( WRAP_MPI_TIMING )
276 : use perf_mod
277 : #endif
278 :
279 : implicit none
280 :
281 : real (r8), intent(in):: buf(*)
282 : integer, intent(in):: count
283 : integer, intent(in):: datatype
284 : integer, intent(in):: dest
285 : integer, intent(in):: tag
286 : integer, intent(in):: comm
287 : integer, intent(out):: request
288 :
289 : integer ier !MP error code
290 :
291 : #if defined( WRAP_MPI_TIMING )
292 : call t_startf ('mpi_isend')
293 : #endif
294 0 : call mpi_isend (buf, count, datatype, dest, tag, comm, request, ier)
295 0 : if (ier/=mpi_success) then
296 0 : write(iulog,*)'mpi_isend failed ier=',ier
297 0 : call endrun
298 : end if
299 0 : nsend = nsend + 1
300 0 : nwsend = nwsend + count
301 : #if defined( WRAP_MPI_TIMING )
302 : call t_stopf ('mpi_isend')
303 : #endif
304 :
305 0 : return
306 : end subroutine mpiisend
307 :
308 : !****************************************************************
309 :
310 0 : subroutine mpiirsend (buf, count, datatype, dest, tag, comm, request)
311 : !
312 : ! Does a non-blocking ready send.
313 : !
314 : use shr_kind_mod, only: r8 => shr_kind_r8
315 : use mpishorthand
316 : use cam_abortutils, only: endrun
317 : use cam_logfile, only: iulog
318 : #if defined( WRAP_MPI_TIMING )
319 : use perf_mod
320 : #endif
321 :
322 : implicit none
323 :
324 : real (r8), intent(in):: buf(*)
325 : integer, intent(in):: count
326 : integer, intent(in):: datatype
327 : integer, intent(in):: dest
328 : integer, intent(in):: tag
329 : integer, intent(in):: comm
330 : integer, intent(out):: request
331 :
332 : integer ier !MP error code
333 :
334 : #if defined( WRAP_MPI_TIMING )
335 : call t_startf ('mpi_irsend')
336 : #endif
337 0 : call mpi_irsend (buf, count, datatype, dest, tag, comm, request, ier)
338 0 : if (ier/=mpi_success) then
339 0 : write(iulog,*)'mpi_irsend failed ier=',ier
340 0 : call endrun
341 : end if
342 0 : nsend = nsend + 1
343 0 : nwsend = nwsend + count
344 : #if defined( WRAP_MPI_TIMING )
345 : call t_stopf ('mpi_irsend')
346 : #endif
347 :
348 0 : return
349 : end subroutine mpiirsend
350 :
351 : !****************************************************************
352 :
353 0 : subroutine mpiissend (buf, count, datatype, dest, tag, comm, request)
354 : !
355 : ! Does a non-blocking synchronous send.
356 : !
357 : use shr_kind_mod, only: r8 => shr_kind_r8
358 : use mpishorthand
359 : use cam_abortutils, only: endrun
360 : use cam_logfile, only: iulog
361 : #if defined( WRAP_MPI_TIMING )
362 : use perf_mod
363 : #endif
364 :
365 : implicit none
366 :
367 : real (r8), intent(in):: buf(*)
368 : integer, intent(in):: count
369 : integer, intent(in):: datatype
370 : integer, intent(in):: dest
371 : integer, intent(in):: tag
372 : integer, intent(in):: comm
373 : integer, intent(out):: request
374 :
375 : integer ier !MP error code
376 :
377 : #if defined( WRAP_MPI_TIMING )
378 : call t_startf ('mpi_issend')
379 : #endif
380 0 : call mpi_issend (buf, count, datatype, dest, tag, comm, request, ier)
381 0 : if (ier/=mpi_success) then
382 0 : write(iulog,*)'mpi_issend failed ier=',ier
383 0 : call endrun
384 : end if
385 0 : nsend = nsend + 1
386 0 : nwsend = nwsend + count
387 : #if defined( WRAP_MPI_TIMING )
388 : call t_stopf ('mpi_issend')
389 : #endif
390 :
391 0 : return
392 : end subroutine mpiissend
393 :
394 : !****************************************************************
395 :
396 0 : subroutine mpiirecv (buf, count, datatype, source, tag, comm, request)
397 : !
398 : ! Does a non-blocking receive.
399 : !
400 : use shr_kind_mod, only: r8 => shr_kind_r8
401 : use mpishorthand
402 : use cam_abortutils, only: endrun
403 : use cam_logfile, only: iulog
404 : #if defined( WRAP_MPI_TIMING )
405 : use perf_mod
406 : #endif
407 :
408 : implicit none
409 :
410 : real (r8), intent(out):: buf(*)
411 : integer, intent(in):: count
412 : integer, intent(in):: datatype
413 : integer, intent(in):: source
414 : integer, intent(in):: tag
415 : integer, intent(in):: comm
416 : integer, intent(out):: request
417 :
418 : integer ier !MP error code
419 :
420 : #if defined( WRAP_MPI_TIMING )
421 : call t_startf ('mpi_irecv')
422 : #endif
423 0 : call mpi_irecv (buf, count, datatype, source, tag, comm, request, ier )
424 0 : if (ier/=mpi_success) then
425 0 : write(iulog,*)'mpi_irecv failed ier=',ier
426 0 : call endrun
427 : end if
428 0 : nrecv = nrecv + 1
429 0 : nwrecv = nwrecv + count
430 : #if defined( WRAP_MPI_TIMING )
431 : call t_stopf ('mpi_irecv')
432 : #endif
433 :
434 0 : return
435 : end subroutine mpiirecv
436 :
437 : !****************************************************************
438 :
439 0 : subroutine mpiwait (request, status)
440 : !
441 : ! Waits for a nonblocking operation to complete.
442 : !
443 : use shr_kind_mod, only: r8 => shr_kind_r8
444 : use mpishorthand
445 : use cam_abortutils, only: endrun
446 : use cam_logfile, only: iulog
447 : #if defined( WRAP_MPI_TIMING )
448 : use perf_mod
449 : #endif
450 :
451 : implicit none
452 :
453 : integer, intent(inout):: request
454 : integer, intent(out):: status
455 :
456 : integer ier !MP error code
457 :
458 : #if defined( WRAP_MPI_TIMING )
459 : call t_startf ('mpi_wait')
460 : #endif
461 0 : call mpi_wait (request, status, ier)
462 0 : if (ier/=mpi_success) then
463 0 : write(iulog,*)'mpi_wait failed ier=',ier
464 0 : call endrun
465 : end if
466 : #if defined( WRAP_MPI_TIMING )
467 : call t_stopf ('mpi_wait')
468 : #endif
469 :
470 0 : return
471 : end subroutine mpiwait
472 :
473 : !****************************************************************
474 :
475 0 : subroutine mpiwaitall (count, array_of_requests, array_of_statuses)
476 : !
477 : ! Waits for a collection of nonblocking operations to complete.
478 : !
479 : use shr_kind_mod, only: r8 => shr_kind_r8
480 : use mpishorthand
481 : use cam_abortutils, only: endrun
482 : use cam_logfile, only: iulog
483 : #if defined( WRAP_MPI_TIMING )
484 : use perf_mod
485 : #endif
486 :
487 : implicit none
488 :
489 : integer, intent(in):: count
490 : integer, intent(inout):: array_of_requests(*)
491 : integer, intent(out):: array_of_statuses(*)
492 :
493 : integer ier !MP error code
494 :
495 : #if defined( WRAP_MPI_TIMING )
496 : call t_startf ('mpi_waitall')
497 : #endif
498 0 : call mpi_waitall (count, array_of_requests, array_of_statuses, ier)
499 0 : if (ier/=mpi_success) then
500 0 : write(iulog,*)'mpi_waitall failed ier=',ier
501 0 : call endrun
502 : end if
503 : #if defined( WRAP_MPI_TIMING )
504 : call t_stopf ('mpi_waitall')
505 : #endif
506 :
507 0 : return
508 : end subroutine mpiwaitall
509 :
510 : !****************************************************************
511 :
512 0 : subroutine mpisend (buf, count, datatype, dest, tag, comm)
513 : !
514 : ! Does a blocking send
515 : !
516 : use shr_kind_mod, only: r8 => shr_kind_r8
517 : use mpishorthand
518 : use cam_abortutils, only: endrun
519 : use cam_logfile, only: iulog
520 : #if defined( WRAP_MPI_TIMING )
521 : use perf_mod
522 : #endif
523 :
524 : implicit none
525 :
526 : real (r8), intent(in):: buf(*)
527 : integer, intent(in):: count
528 : integer, intent(in):: datatype
529 : integer, intent(in):: dest
530 : integer, intent(in):: tag
531 : integer, intent(in):: comm
532 :
533 : integer ier !MP error code
534 :
535 : #if defined( WRAP_MPI_TIMING )
536 : call t_startf ('mpi_send')
537 : #endif
538 0 : call mpi_send (buf, count, datatype, dest, tag, comm, ier)
539 0 : if (ier/=mpi_success) then
540 0 : write(iulog,*)'mpi_send failed ier=',ier
541 0 : call endrun
542 : end if
543 0 : nsend = nsend + 1
544 0 : nwsend = nwsend + count
545 : #if defined( WRAP_MPI_TIMING )
546 : call t_stopf ('mpi_send')
547 : #endif
548 :
549 0 : return
550 : end subroutine mpisend
551 :
552 : !****************************************************************
553 :
554 0 : subroutine mpirsend (buf, count, datatype, dest, tag, comm)
555 : !
556 : ! Does a blocking ready send
557 : !
558 : use shr_kind_mod, only: r8 => shr_kind_r8
559 : use mpishorthand
560 : use cam_abortutils, only: endrun
561 : use cam_logfile, only: iulog
562 : #if defined( WRAP_MPI_TIMING )
563 : use perf_mod
564 : #endif
565 :
566 : implicit none
567 :
568 : real (r8), intent(in):: buf(*)
569 : integer, intent(in):: count
570 : integer, intent(in):: datatype
571 : integer, intent(in):: dest
572 : integer, intent(in):: tag
573 : integer, intent(in):: comm
574 :
575 : integer ier !MP error code
576 :
577 : #if defined( WRAP_MPI_TIMING )
578 : call t_startf ('mpi_rsend')
579 : #endif
580 0 : call mpi_rsend (buf, count, datatype, dest, tag, comm, ier)
581 0 : if (ier/=mpi_success) then
582 0 : write(iulog,*)'mpi_rsend failed ier=',ier
583 0 : call endrun
584 : end if
585 0 : nsend = nsend + 1
586 0 : nwsend = nwsend + count
587 : #if defined( WRAP_MPI_TIMING )
588 : call t_stopf ('mpi_rsend')
589 : #endif
590 :
591 0 : return
592 : end subroutine mpirsend
593 :
594 : !****************************************************************
595 :
596 0 : subroutine mpissend (buf, count, datatype, dest, tag, comm)
597 : !
598 : ! Does a blocking synchronous send
599 : !
600 : use shr_kind_mod, only: r8 => shr_kind_r8
601 : use mpishorthand
602 : use cam_abortutils, only: endrun
603 : use cam_logfile, only: iulog
604 : #if defined( WRAP_MPI_TIMING )
605 : use perf_mod
606 : #endif
607 :
608 : implicit none
609 :
610 : real (r8), intent(in):: buf(*)
611 : integer, intent(in):: count
612 : integer, intent(in):: datatype
613 : integer, intent(in):: dest
614 : integer, intent(in):: tag
615 : integer, intent(in):: comm
616 :
617 : integer ier !MP error code
618 :
619 : #if defined( WRAP_MPI_TIMING )
620 : call t_startf ('mpi_ssend')
621 : #endif
622 0 : call mpi_ssend (buf, count, datatype, dest, tag, comm, ier)
623 0 : if (ier/=mpi_success) then
624 0 : write(iulog,*)'mpi_ssend failed ier=',ier
625 0 : call endrun
626 : end if
627 0 : nsend = nsend + 1
628 0 : nwsend = nwsend + count
629 : #if defined( WRAP_MPI_TIMING )
630 : call t_stopf ('mpi_ssend')
631 : #endif
632 :
633 0 : return
634 : end subroutine mpissend
635 :
636 : !****************************************************************
637 :
638 0 : subroutine mpirecv (buf, count, datatype, source, tag, comm)
639 : !
640 : ! Does a blocking receive
641 : !
642 : use shr_kind_mod, only: r8 => shr_kind_r8
643 : use mpishorthand
644 : use cam_abortutils, only: endrun
645 : use cam_logfile, only: iulog
646 : #if defined( WRAP_MPI_TIMING )
647 : use perf_mod
648 : #endif
649 :
650 : implicit none
651 :
652 : real (r8), intent(out):: buf(*)
653 : integer, intent(in):: count
654 : integer, intent(in):: datatype
655 : integer, intent(in):: source
656 : integer, intent(in):: tag
657 : integer, intent(in):: comm
658 :
659 : integer status (MPI_STATUS_SIZE) ! Status of message
660 : integer ier !MP error code
661 :
662 : #if defined( WRAP_MPI_TIMING )
663 : call t_startf ('mpi_recv')
664 : #endif
665 0 : call mpi_recv (buf, count, datatype, source, tag, comm, status, ier)
666 0 : if (ier/=mpi_success) then
667 0 : write(iulog,*)'mpi_recv failed ier=',ier
668 0 : call endrun
669 : end if
670 0 : nrecv = nrecv + 1
671 0 : nwrecv = nwrecv + count
672 : #if defined( WRAP_MPI_TIMING )
673 : call t_stopf ('mpi_recv')
674 : #endif
675 :
676 0 : return
677 : end subroutine mpirecv
678 :
679 : !****************************************************************
680 :
681 0 : subroutine mpigather (sendbuf, sendcnt, sendtype, recvbuf, recvcnt, &
682 : recvtype, root, comm)
683 : !
684 : ! Collects different messages from each thread on masterproc
685 : !
686 : use shr_kind_mod, only: r8 => shr_kind_r8
687 : use mpishorthand
688 : use cam_abortutils, only: endrun
689 : use cam_logfile, only: iulog
690 : #if defined( WRAP_MPI_TIMING )
691 : use perf_mod
692 : #endif
693 :
694 : implicit none
695 :
696 : real (r8), intent(in):: sendbuf(*)
697 : real (r8), intent(out):: recvbuf(*)
698 : integer, intent(in):: sendcnt
699 : integer, intent(in):: sendtype
700 : integer, intent(in):: recvcnt
701 : integer, intent(in):: recvtype
702 : integer, intent(in):: root
703 : integer, intent(in):: comm
704 :
705 : integer ier !MP error code
706 :
707 : #if defined( WRAP_MPI_TIMING )
708 : call t_startf ('mpi_gather')
709 : #endif
710 : call mpi_gather (sendbuf, sendcnt, sendtype, &
711 0 : recvbuf, recvcnt, recvtype, root, comm, ier)
712 0 : if (ier/=mpi_success) then
713 0 : write(iulog,*)'mpi_gather failed ier=',ier
714 0 : call endrun
715 : end if
716 : #if defined( WRAP_MPI_TIMING )
717 : call t_stopf ('mpi_gather')
718 : #endif
719 :
720 0 : return
721 : end subroutine mpigather
722 :
723 : !****************************************************************
724 :
725 0 : subroutine mpigatherv (sendbuf, sendcnt, sendtype, recvbuf, recvcnts, &
726 : displs, recvtype, root, comm)
727 : !
728 : ! Collects different messages from each thread on masterproc
729 : !
730 : use shr_kind_mod, only: r8 => shr_kind_r8
731 : use mpishorthand
732 : use cam_abortutils, only: endrun
733 : use cam_logfile, only: iulog
734 : #if defined( WRAP_MPI_TIMING )
735 : use perf_mod
736 : #endif
737 :
738 : implicit none
739 :
740 : real (r8), intent(in) :: sendbuf(*)
741 : real (r8), intent(out) :: recvbuf(*)
742 : integer, intent(in) :: displs(*)
743 : integer, intent(in) :: sendcnt
744 : integer, intent(in) :: sendtype
745 : integer, intent(in) :: recvcnts(*)
746 : integer, intent(in) :: recvtype
747 : integer, intent(in) :: root
748 : integer, intent(in) :: comm
749 :
750 : integer ier ! MPI error code
751 :
752 : #if defined( WRAP_MPI_TIMING )
753 : call t_startf ('mpi_gatherv')
754 : #endif
755 : call mpi_gatherv (sendbuf, sendcnt, sendtype, recvbuf, recvcnts, displs, recvtype, &
756 0 : root, comm, ier)
757 0 : if (ier /= mpi_success) then
758 0 : write(iulog,*)'mpi_gatherv failed ier=',ier
759 0 : call endrun
760 : end if
761 : #if defined( WRAP_MPI_TIMING )
762 : call t_stopf ('mpi_gatherv')
763 : #endif
764 :
765 0 : return
766 : end subroutine mpigatherv
767 :
768 : !****************************************************************
769 :
770 0 : subroutine mpigathervr4 (sendbuf, sendcnt, sendtype, recvbuf, recvcnts, &
771 : displs, recvtype, root, comm)
772 : !
773 : ! Collects different messages from each thread on masterproc
774 : !
775 : use shr_kind_mod, only: r4 => shr_kind_r4, r8 => shr_kind_r8
776 : use mpishorthand
777 : use cam_abortutils, only: endrun
778 : use cam_logfile, only: iulog
779 : #if defined( WRAP_MPI_TIMING )
780 : use perf_mod
781 : #endif
782 :
783 : implicit none
784 :
785 : real (r4), intent(in) :: sendbuf(*)
786 : real (r4), intent(out) :: recvbuf(*)
787 : integer, intent(in) :: displs(*)
788 : integer, intent(in) :: sendcnt
789 : integer, intent(in) :: sendtype
790 : integer, intent(in) :: recvcnts(*)
791 : integer, intent(in) :: recvtype
792 : integer, intent(in) :: root
793 : integer, intent(in) :: comm
794 :
795 : integer ier ! MPI error code
796 :
797 : #if defined( WRAP_MPI_TIMING )
798 : call t_startf ('mpi_gatherv')
799 : #endif
800 : call mpi_gatherv (sendbuf, sendcnt, sendtype, recvbuf, recvcnts, displs, recvtype, &
801 0 : root, comm, ier)
802 0 : if (ier /= mpi_success) then
803 0 : write(iulog,*)'mpi_gatherv failed ier=',ier
804 0 : call endrun
805 : end if
806 : #if defined( WRAP_MPI_TIMING )
807 : call t_stopf ('mpi_gatherv')
808 : #endif
809 :
810 0 : return
811 : end subroutine mpigathervr4
812 :
813 : !****************************************************************
814 :
815 0 : subroutine mpigathervint (sendbuf, sendcnt, sendtype, recvbuf, &
816 : recvcnts, displs, recvtype, root, comm)
817 : !
818 : ! Collects different messages from each thread on masterproc
819 : !
820 : use shr_kind_mod, only: r8 => shr_kind_r8
821 : use mpishorthand
822 : use cam_abortutils, only: endrun
823 : use cam_logfile, only: iulog
824 : #if defined( WRAP_MPI_TIMING )
825 : use perf_mod
826 : #endif
827 :
828 : implicit none
829 :
830 : integer, intent(in) :: sendbuf(*)
831 : integer, intent(out) :: recvbuf(*)
832 : integer, intent(in) :: displs(*)
833 : integer, intent(in) :: sendcnt
834 : integer, intent(in) :: sendtype
835 : integer, intent(in) :: recvcnts(*)
836 : integer, intent(in) :: recvtype
837 : integer, intent(in) :: root
838 : integer, intent(in) :: comm
839 :
840 : integer ier ! MPI error code
841 :
842 : #if defined( WRAP_MPI_TIMING )
843 : call t_startf ('mpi_gatherv')
844 : #endif
845 : call mpi_gatherv (sendbuf, sendcnt, sendtype, recvbuf, recvcnts, displs, recvtype, &
846 0 : root, comm, ier)
847 0 : if (ier /= mpi_success) then
848 0 : write(iulog,*)'mpi_gatherv failed ier=',ier
849 0 : call endrun
850 : end if
851 : #if defined( WRAP_MPI_TIMING )
852 : call t_stopf ('mpi_gatherv')
853 : #endif
854 :
855 0 : return
856 : end subroutine mpigathervint
857 :
858 : !****************************************************************
859 :
860 0 : subroutine mpisum (sendbuf, recvbuf, cnt, datatype, root, comm)
861 : !
862 : ! Sums sendbuf across all processors on communicator, returning
863 : ! result to root.
864 : !
865 : use shr_kind_mod, only: r8 => shr_kind_r8
866 : use mpishorthand
867 : use cam_abortutils, only: endrun
868 : use cam_logfile, only: iulog
869 : #if defined( WRAP_MPI_TIMING )
870 : use perf_mod
871 : #endif
872 :
873 : implicit none
874 :
875 : real (r8), intent(in):: sendbuf(*)
876 : real (r8), intent(out):: recvbuf(*)
877 : integer, intent(in):: cnt
878 : integer, intent(in):: datatype
879 : integer, intent(in):: root
880 : integer, intent(in):: comm
881 :
882 : integer ier !MP error code
883 :
884 : #if defined( WRAP_MPI_TIMING )
885 : call t_startf ('mpi_reduce')
886 : #endif
887 : call mpi_reduce (sendbuf, recvbuf, cnt, datatype, mpi_sum, &
888 0 : root, comm, ier)
889 0 : if (ier/=mpi_success) then
890 0 : write(iulog,*)'mpi_reduce failed ier=',ier
891 0 : call endrun
892 : end if
893 : #if defined( WRAP_MPI_TIMING )
894 : call t_stopf ('mpi_reduce')
895 : #endif
896 :
897 0 : return
898 : end subroutine mpisum
899 :
900 : !****************************************************************
901 :
902 0 : subroutine mpiscatter (sendbuf, sendcnt, sendtype, recvbuf, recvcnt, &
903 : recvtype, root, comm)
904 : !
905 : ! Sends different messages from masterproc to each thread
906 : !
907 : use shr_kind_mod, only: r8 => shr_kind_r8
908 : use mpishorthand
909 : use cam_abortutils, only: endrun
910 : use cam_logfile, only: iulog
911 : #if defined( WRAP_MPI_TIMING )
912 : use perf_mod
913 : #endif
914 :
915 : implicit none
916 :
917 : real (r8),intent(in):: sendbuf(*)
918 : real (r8), intent(out):: recvbuf(*)
919 : integer,intent(in):: sendcnt
920 : integer,intent(in):: sendtype
921 : integer,intent(in):: recvcnt
922 : integer,intent(in):: recvtype
923 : integer,intent(in):: root
924 : integer,intent(in):: comm
925 :
926 : integer ier !MP error code
927 :
928 : #if defined( WRAP_MPI_TIMING )
929 : call t_startf ('mpi_scatter')
930 : #endif
931 : call mpi_scatter (sendbuf, sendcnt, sendtype, recvbuf, recvcnt, &
932 0 : recvtype, root, comm, ier)
933 0 : if (ier/=mpi_success) then
934 0 : write(iulog,*)'mpi_scatter failed ier=',ier
935 0 : call endrun
936 : end if
937 : #if defined( WRAP_MPI_TIMING )
938 : call t_stopf ('mpi_scatter')
939 : #endif
940 :
941 0 : return
942 : end subroutine mpiscatter
943 :
944 : !****************************************************************
945 :
946 0 : subroutine mpiscatterv (sendbuf, sendcnts, displs, sendtype, recvbuf, &
947 : recvcnt, recvtype, root, comm)
948 : !
949 : ! Sends different messages from masterproc to each thread
950 : !
951 : use shr_kind_mod, only: r8 => shr_kind_r8
952 : use mpishorthand
953 : use cam_abortutils, only: endrun
954 : use cam_logfile, only: iulog
955 : #if defined( WRAP_MPI_TIMING )
956 : use perf_mod
957 : #endif
958 :
959 : implicit none
960 :
961 : real (r8), intent(in) :: sendbuf(*)
962 : real (r8), intent(out) :: recvbuf(*)
963 : integer, intent(in) :: displs(*)
964 : integer, intent(in) :: sendcnts(*)
965 : integer, intent(in) :: sendtype
966 : integer, intent(in) :: recvcnt
967 : integer, intent(in) :: recvtype
968 : integer, intent(in) :: root
969 : integer, intent(in) :: comm
970 :
971 : integer ier !MP error code
972 :
973 : #if defined( WRAP_MPI_TIMING )
974 : call t_startf ('mpi_scatter')
975 : #endif
976 : call mpi_scatterv (sendbuf, sendcnts, displs, sendtype, recvbuf, recvcnt, &
977 0 : recvtype, root, comm, ier)
978 0 : if (ier/=mpi_success) then
979 0 : write(iulog,*)'mpi_scatter failed ier=',ier
980 0 : call endrun
981 : end if
982 : #if defined( WRAP_MPI_TIMING )
983 : call t_stopf ('mpi_scatter')
984 : #endif
985 :
986 0 : return
987 : end subroutine mpiscatterv
988 :
989 : !****************************************************************
990 :
991 282624 : subroutine mpibcast (buffer, count, datatype, root, comm )
992 : !
993 : ! Broadcasts a message from masterproc to all threads
994 : !
995 : use shr_kind_mod, only: r8 => shr_kind_r8
996 : use mpishorthand
997 : use cam_abortutils, only: endrun
998 : use cam_logfile, only: iulog
999 : #if defined( WRAP_MPI_TIMING )
1000 : use perf_mod
1001 : #endif
1002 :
1003 : implicit none
1004 :
1005 : real (r8), intent(inout):: buffer(*)
1006 : integer, intent(in):: count
1007 : integer, intent(in):: datatype
1008 : integer, intent(in):: root
1009 : integer, intent(in):: comm
1010 :
1011 : integer ier !MP error code
1012 :
1013 : #if defined( WRAP_MPI_TIMING )
1014 : call t_startf ('mpi_bcast')
1015 : #endif
1016 282624 : call mpi_bcast (buffer, count, datatype, root, comm, ier)
1017 282624 : if (ier/=mpi_success) then
1018 0 : write(iulog,*)'mpi_bcast failed ier=',ier
1019 0 : call endrun
1020 : end if
1021 : #if defined( WRAP_MPI_TIMING )
1022 : call t_stopf ('mpi_bcast')
1023 : #endif
1024 :
1025 282624 : return
1026 : end subroutine mpibcast
1027 : !****************************************************************
1028 :
1029 0 : subroutine mpiallmaxint (sendbuf, recvbuf, count, comm)
1030 : !
1031 : ! Allreduce integer vector maximum
1032 : !
1033 : use mpishorthand
1034 : use cam_abortutils, only: endrun
1035 : use cam_logfile, only: iulog
1036 : #if defined( WRAP_MPI_TIMING )
1037 : use perf_mod
1038 : #endif
1039 :
1040 : implicit none
1041 :
1042 : integer, intent(in) :: sendbuf(*)
1043 : integer, intent(out) :: recvbuf(*)
1044 : integer, intent(in) :: count
1045 : integer, intent(in) :: comm
1046 :
1047 : integer :: ier ! MPI error code
1048 :
1049 : #if defined( WRAP_MPI_TIMING )
1050 : call t_startf ('mpi_allreduce')
1051 : #endif
1052 : call mpi_allreduce (sendbuf, recvbuf, count, mpiint, &
1053 0 : mpimax, comm, ier)
1054 0 : if (ier/=mpi_success) then
1055 0 : write(iulog,*)'mpi_allreduce failed ier=',ier
1056 0 : call endrun
1057 : end if
1058 : #if defined( WRAP_MPI_TIMING )
1059 : call t_stopf ('mpi_allreduce')
1060 : #endif
1061 :
1062 0 : return
1063 : end subroutine mpiallmaxint
1064 :
1065 : !****************************************************************
1066 :
1067 0 : subroutine mpialltoallv (sendbuf, sendcnts, sdispls, sendtype, &
1068 : recvbuf, recvcnts, rdispls, recvtype, &
1069 : comm)
1070 : !
1071 : ! All-to-all scatter/gather
1072 : !
1073 : use shr_kind_mod, only: r8 => shr_kind_r8
1074 : use mpishorthand
1075 : use cam_abortutils, only: endrun
1076 : use cam_logfile, only: iulog
1077 : #if defined( WRAP_MPI_TIMING )
1078 : use perf_mod
1079 : #endif
1080 :
1081 : implicit none
1082 :
1083 : real (r8), intent(in) :: sendbuf(*)
1084 : real (r8), intent(out) :: recvbuf(*)
1085 : integer, intent(in) :: sdispls(*)
1086 : integer, intent(in) :: sendcnts(*)
1087 : integer, intent(in) :: sendtype
1088 : integer, intent(in) :: recvcnts(*)
1089 : integer, intent(in) :: rdispls(*)
1090 : integer, intent(in) :: recvtype
1091 : integer, intent(in) :: comm
1092 :
1093 : integer :: ier ! MPI error code
1094 :
1095 : #if defined( WRAP_MPI_TIMING )
1096 : call t_startf ('mpi_alltoallv')
1097 : #endif
1098 : call mpi_alltoallv (sendbuf, sendcnts, sdispls, sendtype, &
1099 : recvbuf, recvcnts, rdispls, recvtype, &
1100 0 : comm, ier)
1101 0 : if (ier/=mpi_success) then
1102 0 : write(iulog,*)'mpi_alltoallv failed ier=',ier
1103 0 : call endrun
1104 : end if
1105 : #if defined( WRAP_MPI_TIMING )
1106 : call t_stopf ('mpi_alltoallv')
1107 : #endif
1108 :
1109 0 : return
1110 : end subroutine mpialltoallv
1111 : !****************************************************************
1112 :
1113 0 : subroutine mpialltoallint (sendbuf, sendcnt, recvbuf, recvcnt, &
1114 : comm)
1115 : !
1116 : ! All-to-all scatter/gather
1117 : !
1118 : use shr_kind_mod, only: r8 => shr_kind_r8
1119 : use mpishorthand
1120 : use cam_abortutils, only: endrun
1121 : use cam_logfile, only: iulog
1122 : #if defined( WRAP_MPI_TIMING )
1123 : use perf_mod
1124 : #endif
1125 :
1126 : implicit none
1127 :
1128 : integer, intent(in) :: sendbuf(*)
1129 : integer, intent(in) :: sendcnt
1130 : integer, intent(out) :: recvbuf(*)
1131 : integer, intent(in) :: recvcnt
1132 : integer, intent(in) :: comm
1133 :
1134 : integer :: ier ! MPI error code
1135 :
1136 : #if defined( WRAP_MPI_TIMING )
1137 : call t_startf ('mpi_alltoallint')
1138 : #endif
1139 : call mpi_alltoall (sendbuf, sendcnt, mpiint, &
1140 : recvbuf, recvcnt, mpiint, &
1141 0 : comm, ier)
1142 0 : if (ier/=mpi_success) then
1143 0 : write(iulog,*)'mpi_alltoallint failed ier=',ier
1144 0 : call endrun
1145 : end if
1146 : #if defined( WRAP_MPI_TIMING )
1147 : call t_stopf ('mpi_alltoallint')
1148 : #endif
1149 :
1150 0 : return
1151 : end subroutine mpialltoallint
1152 :
1153 : !****************************************************************
1154 :
1155 0 : subroutine mpiallgatherv (sendbuf, sendcnt, sendtype, &
1156 : recvbuf, recvcnts, rdispls, recvtype, &
1157 : comm)
1158 : !
1159 : ! Collect data from each task and broadcast resulting
1160 : ! vector to all tasks
1161 : !
1162 : use shr_kind_mod, only: r8 => shr_kind_r8
1163 : use mpishorthand
1164 : use cam_abortutils, only: endrun
1165 : use cam_logfile, only: iulog
1166 : #if defined( WRAP_MPI_TIMING )
1167 : use perf_mod
1168 : #endif
1169 :
1170 : implicit none
1171 :
1172 : real (r8), intent(in) :: sendbuf(*)
1173 : real (r8), intent(out) :: recvbuf(*)
1174 : integer, intent(in) :: sendcnt
1175 : integer, intent(in) :: sendtype
1176 : integer, intent(in) :: recvcnts(*)
1177 : integer, intent(in) :: rdispls(*)
1178 : integer, intent(in) :: recvtype
1179 : integer, intent(in) :: comm
1180 :
1181 : integer ier !MP error code
1182 :
1183 : #if defined( WRAP_MPI_TIMING )
1184 : call t_startf ('mpi_allgatherv')
1185 : #endif
1186 : call mpi_allgatherv (sendbuf, sendcnt, sendtype, &
1187 : recvbuf, recvcnts, rdispls, recvtype, &
1188 0 : comm, ier)
1189 0 : if (ier/=mpi_success) then
1190 0 : write(iulog,*)'mpi_allgatherv failed ier=',ier
1191 0 : call endrun
1192 : end if
1193 : #if defined( WRAP_MPI_TIMING )
1194 : call t_stopf ('mpi_allgatherv')
1195 : #endif
1196 :
1197 0 : return
1198 : end subroutine mpiallgatherv
1199 : !****************************************************************
1200 :
1201 0 : subroutine mpiallgatherint (sendbuf, scount, recvbuf, rcount, comm)
1202 : !
1203 : ! Collects integer data from each task and broadcasts resulting
1204 : ! vector to all tasks
1205 : !
1206 : use shr_kind_mod, only: r8 => shr_kind_r8
1207 : use mpishorthand
1208 : use cam_abortutils, only: endrun
1209 : use cam_logfile, only: iulog
1210 : #if defined( WRAP_MPI_TIMING )
1211 : use perf_mod
1212 : #endif
1213 :
1214 : implicit none
1215 :
1216 : integer, intent(in) :: sendbuf(*)
1217 : integer, intent(out) :: recvbuf(*)
1218 : integer, intent(in) :: scount
1219 : integer, intent(in) :: rcount
1220 : integer, intent(in) :: comm
1221 :
1222 : integer ier !MP error code
1223 :
1224 : #if defined( WRAP_MPI_TIMING )
1225 : call t_startf ('mpi_allgather')
1226 : #endif
1227 : call mpi_allgather (sendbuf, scount, mpiint, recvbuf, rcount, &
1228 0 : mpiint, comm, ier)
1229 0 : if (ier/=mpi_success) then
1230 0 : write(iulog,*)'mpi_allgather failed ier=',ier
1231 0 : call endrun
1232 : end if
1233 : #if defined( WRAP_MPI_TIMING )
1234 : call t_stopf ('mpi_allgather')
1235 : #endif
1236 :
1237 0 : return
1238 : end subroutine mpiallgatherint
1239 :
1240 : !****************************************************************
1241 :
1242 0 : subroutine mpiwincreate(base,size,comm,win)
1243 : !
1244 : ! Creates window for MPI2 one-sided commands
1245 : !
1246 : use shr_kind_mod, only: r8 => shr_kind_r8
1247 : use mpishorthand
1248 : use cam_abortutils, only: endrun
1249 : use cam_logfile, only: iulog
1250 : #if defined( WRAP_MPI_TIMING )
1251 : use perf_mod
1252 : #endif
1253 :
1254 : implicit none
1255 :
1256 : real(r8), intent(in) :: base(*)
1257 : integer, intent(in) :: size
1258 : integer, intent(in) :: comm
1259 : integer, intent(out) :: win
1260 : !
1261 : #ifdef MPI2
1262 : integer(kind=MPI_ADDRESS_KIND) :: size8
1263 : integer :: ier, info
1264 : !
1265 : #if defined( WRAP_MPI_TIMING )
1266 : call t_startf ('mpi_win_create')
1267 : #endif
1268 : info = MPI_INFO_NULL
1269 : size8 = size
1270 : call mpi_win_create(base,size8,8,info,comm,win,ier)
1271 : if (ier/=mpi_success) then
1272 : write(iulog,*)'mpi_win_create failed ier=',ier
1273 : call endrun
1274 : end if
1275 : call mpi_win_fence(0,win,ier)
1276 : if (ier/=mpi_success) then
1277 : write(iulog,*)'mpi_win_fence failed ier=',ier
1278 : call endrun
1279 : end if
1280 : #if defined( WRAP_MPI_TIMING )
1281 : call t_stopf ('mpi_win_create')
1282 : #endif
1283 : #endif
1284 :
1285 0 : return
1286 : end subroutine mpiwincreate
1287 : !****************************************************************
1288 : !
1289 : ! If SPMD is not turned on
1290 : !
1291 : #else
1292 : subroutine wrap_mpi
1293 : use cam_abortutils, only: endrun
1294 : implicit none
1295 : !
1296 : ! A unused stub routine to make the compiler happy when SPMD is
1297 : ! turned off (which means you don't need anything in this file).
1298 : !
1299 : call endrun ('(WRAP_MPI): This should not be called at all')
1300 : end subroutine wrap_mpi
1301 : #endif
1302 :
|
