Line data Source code
1 : module spmd_utils
2 :
3 : !-----------------------------------------------------------------------
4 : !
5 : ! Purpose: This module is responsible for miscellaneous SPMD utilities
6 : ! and information that are shared between dynamics and
7 : ! physics packages.
8 : !
9 : ! Author:
10 : ! Original routines: CMS
11 : ! Module: T. Henderson, December 2003
12 : ! swap routines: P. Worley
13 : ! fc routines: P. Worley
14 : ! SMP node id logic: P. Worley
15 : !
16 : ! $Id$
17 : !
18 : !-----------------------------------------------------------------------
19 :
20 : !
21 : ! Performance bug work around for Gemini interconnect
22 : !
23 : #ifdef _NO_MPI_RSEND
24 : #define mpi_rsend mpi_send
25 : #define mpi_irsend mpi_isend
26 : #endif
27 :
28 : !-----------------------------------------------------------------------
29 : !- use statements ------------------------------------------------------
30 : !-----------------------------------------------------------------------
31 : use shr_kind_mod, only: r8 => shr_kind_r8
32 : use cam_abortutils, only: endrun
33 :
34 : #if ( defined SPMD )
35 : use mpishorthand, only: mpiint, mpii8, mpichar, mpilog, mpipk, &
36 : mpic16, mpir8, mpir4, mpicom, mpimax
37 : #endif
38 : use cam_logfile, only: iulog
39 :
40 : !-----------------------------------------------------------------------
41 : !- module boilerplate --------------------------------------------------
42 : !-----------------------------------------------------------------------
43 : implicit none
44 : include 'mpif.h'
45 : private ! Make the default access private
46 : save
47 : !
48 : ! Forward from mpishorthand.F with the idea of phasing out use of and removing that file
49 : !
50 : #ifndef SPMD
51 :
52 : integer :: mpir8
53 : #endif
54 : !
55 : ! Forward these from mpif.h (or mpi.mod), the idea being that this should
56 : ! be the only module that uses mpi directly, the rest of cam should use spmd_utils
57 : !
58 : public :: mpi_max_processor_name, mpi_max_error_string, mpi_error, &
59 : mpi_integer, mpi_integer8, mpi_character, mpi_double_precision, &
60 : mpi_logical, mpi_real8, mpi_real4, mpi_complex16, &
61 : mpi_packed, mpi_tag_ub, mpi_info_null, &
62 : mpi_comm_null, mpi_group_null, mpi_undefined, &
63 : mpi_status_size, mpi_success, mpi_status_ignore, &
64 : mpi_max, mpi_min, mpi_sum, mpi_band, mpir8
65 : #if ( defined SPMD )
66 : public :: mpi_address_kind
67 : #endif
68 :
69 : !-----------------------------------------------------------------------
70 : ! Public interfaces ----------------------------------------------------
71 : !-----------------------------------------------------------------------
72 : public pair ! $$$here... originally from eul|sld/spmd_dyn
73 : public ceil2 ! $$$here... originally from eul|sld/spmd_dyn
74 : public spmdinit
75 : public spmd_utils_readnl
76 : #if ( defined SPMD )
77 : public swapm
78 : public fc_gatherv
79 : public fc_gathervr4
80 : public fc_gathervint
81 : public fc_gathervc
82 : public altalltoallv
83 : #endif
84 :
85 : !-----------------------------------------------------------------------
86 : ! Public communication types--------------------------------------------
87 : !-----------------------------------------------------------------------
88 : type, public :: spmd_col_trans
89 : ! spmd_col_trans holds information for setting up a communications pattern
90 : integer :: source_task
91 : integer :: source_index
92 : integer :: dest_task
93 : integer :: dest_index
94 : integer :: mpi_tag
95 : end type spmd_col_trans
96 :
97 : type, public :: column_redist_t
98 : ! column_redist_t holds information needed to redistribute columns
99 : ! Fields used for both send and receive
100 : integer :: mpi_comm = MPI_COMM_NULL ! Comm for dest tasks
101 : integer :: recv_iam = -1 ! rank in mpi_comm
102 : integer :: recv_master_id = -1 ! rank of mpi_comm 'master'
103 : integer :: max_nflds = 0 ! max fields at one time
104 : integer :: num_rounds = 0 ! # of field sum blocks
105 : integer, pointer :: dest_tasks(:) => NULL() ! Destination tasks
106 : integer, pointer :: col_starts(:) => NULL() ! Global start col per dest
107 : integer, pointer :: num_rflds(:) => NULL() ! # flds per round
108 : ! Data used by receiving tasks
109 : integer, pointer :: recv_cnts(:) => NULL() ! # cols from each PE
110 : integer, pointer :: recv_disps(:) => NULL() ! col offsets from each PE
111 : integer, pointer :: recv_reorder(:) => NULL() ! Reordering after receive
112 : ! Data used by sending tasks
113 : integer :: strt_nfld = -1 ! first field for this task
114 : integer :: my_nflds = 0 ! # fields for this task
115 : integer, pointer :: task_sizes(:) => NULL() ! # of task cols per dest
116 : integer, pointer :: task_indices(:) => NULL() ! Global index for each col
117 : integer, pointer :: send_disps(:) => NULL() ! cols offsets to each PE
118 : integer, pointer :: send_reorder(:) => NULL() ! Reordering before send
119 : end type column_redist_t
120 :
121 : !-----------------------------------------------------------------------
122 : ! Public data ----------------------------------------------------------
123 : !-----------------------------------------------------------------------
124 : ! physics-motivated dynamics decomposition request
125 : logical, parameter :: def_mirror = .false. ! default
126 : logical, public :: phys_mirror_decomp_req = def_mirror
127 : ! flag indicating whether latitudes and their
128 : ! reflections across the equator should be
129 : ! assigned to consecutive processes
130 :
131 : #if (defined SPMD)
132 : public :: mpicom
133 : public :: mpichar
134 : #else
135 : integer, public :: mpicom
136 : integer, public :: mpichar
137 : #endif
138 : logical, public :: masterproc
139 : integer, public :: masterprocid
140 : integer, public :: iam
141 : integer, public :: npes
142 : integer, public :: nsmps
143 : integer, allocatable, public :: proc_smp_map(:)
144 : ! DEFAULT_MASTERPROC is the value of iam which is assigned masterproc duties
145 : integer, parameter :: DEFAULT_MASTERPROC = 0
146 : ! spmd_col_trans_mpi_type is a handle to be used for column reordering
147 : integer, public, protected :: spmd_col_trans_mpi_type
148 :
149 : !-----------------------------------------------------------------------
150 : ! Private data ---------------------------------------------------------
151 : !-----------------------------------------------------------------------
152 : ! Swap communication protocol options (reduced set):
153 : ! 3, 5: nonblocking send
154 : ! 2, 3, 4, 5: nonblocking receive
155 : ! 4, 5: ready send
156 : integer, private, parameter :: min_comm_protocol = 2
157 : integer, private, parameter :: max_comm_protocol = 5
158 : integer, private, parameter :: def_comm_protocol = 4 ! default
159 : integer, public :: swap_comm_protocol = def_comm_protocol
160 :
161 : ! Swap communication maximum request count:
162 : ! = -1,0: do not limit number of outstanding send/receive requests
163 : ! > 0: do not allow more than swap_comm_maxreq outstanding
164 : ! nonblocking send requests or nonblocking receive requests
165 : integer, private, parameter :: def_comm_maxreq = 128 ! default
166 : integer, public :: swap_comm_maxreq = def_comm_maxreq
167 :
168 : ! Flow-controlled gather option:
169 : ! < 0: use MPI_Gather
170 : ! >= 0: use point-to-point with handshaking messages and
171 : ! preposting receive requests up to
172 : ! min(max(1,fc_gather_flow_cntl),max_gather_block_size)
173 : ! ahead
174 : integer, private, parameter :: max_gather_block_size = 64 ! max and default
175 : integer, public :: fc_gather_flow_cntl = max_gather_block_size
176 :
177 : !-----------------------------------------------------------------------
178 : ! Subroutines and functions --------------------------------------------
179 : !-----------------------------------------------------------------------
180 : contains
181 :
182 : !========================================================================
183 :
184 0 : integer function pair(np,p,k)
185 :
186 : integer np,p,k,q
187 0 : q = ieor(p,k)
188 0 : if(q.gt.np-1) then
189 : pair = -1
190 : else
191 0 : pair = q
192 : endif
193 : return
194 :
195 : end function pair
196 :
197 : !========================================================================
198 :
199 0 : integer function ceil2(n)
200 : integer n,p
201 0 : p=1
202 0 : do while(p.lt.n)
203 0 : p=p*2
204 : enddo
205 0 : ceil2=p
206 : return
207 : end function ceil2
208 :
209 : !========================================================================
210 :
211 1536 : subroutine spmdinit( mpicom_atm )
212 : !-----------------------------------------------------------------------
213 : !
214 : ! Purpose: MPI initialization routine:
215 : !
216 : ! Method: get number of cpus, processes, tids, etc
217 : ! dynamics and physics decompositions are set up later
218 : !
219 : ! Author: CCM Core Group
220 : !
221 : !-----------------------------------------------------------------------
222 :
223 : implicit none
224 : integer, intent(in) :: mpicom_atm
225 :
226 : #if ( defined SPMD )
227 : !
228 : ! Local workspace
229 : !
230 : integer i,j,c ! indices
231 : integer npthreads ! thread status
232 : integer ier ! return error status
233 : integer length ! length of name
234 : integer max_len ! maximum name length
235 1536 : integer, allocatable :: lengths(:)! max lengths of names for use in gatherv
236 1536 : integer, allocatable :: displs(:) ! offsets for use in gatherv
237 : logical done
238 1536 : character, allocatable :: proc_name(:) ! processor name, this task
239 1536 : character, allocatable :: proc_names(:) ! processor names, all tasks
240 : character(len=mpi_max_processor_name) :: tmp_name ! temporary storage
241 1536 : character(len=mpi_max_processor_name), allocatable :: smp_names(:) ! SMP name
242 : logical mpi_running ! returned value indicates if MPI_INIT has been called
243 : ! For creating new MPI type for column info transfer
244 : integer :: h1, hind
245 : integer :: ierr
246 : integer(kind=MPI_ADDRESS_KIND) :: offsets(6) ! For new MPI types
247 : integer :: origtypes(6) ! For new MPI types
248 : integer(kind=MPI_ADDRESS_KIND) :: extent ! For new MPI types
249 : type(spmd_col_trans) :: dummy_loc(2) ! For new MPI types
250 : type(spmd_col_trans) :: col_trans_type_temp
251 :
252 : !---------------------------------------------------------------------------
253 : !
254 : ! Determine CAM MPI communicator group
255 : !
256 1536 : mpicom = mpicom_atm
257 : !
258 : ! Set mpishorthand variables. Need to set as variables rather than parameters since
259 : ! some MPI implementations set values for MPI tags at run time
260 : !
261 1536 : mpiint = mpi_integer
262 1536 : mpii8 = mpi_integer8
263 1536 : mpichar = mpi_character
264 1536 : mpilog = mpi_logical
265 1536 : mpir4 = mpi_real4
266 1536 : mpir8 = mpi_real8
267 1536 : mpic16 = mpi_complex16
268 1536 : mpipk = mpi_packed
269 1536 : mpimax = mpi_max
270 : !
271 : ! Get my id
272 : !
273 1536 : call mpi_comm_rank (mpicom, iam, ier)
274 1536 : masterprocid = DEFAULT_MASTERPROC
275 1536 : if (iam == DEFAULT_MASTERPROC) then
276 2 : masterproc = .true.
277 : else
278 1534 : masterproc = .false.
279 : end if
280 : !
281 : ! Get number of processors
282 : !
283 1536 : max_len = mpi_max_processor_name
284 1536 : call mpi_comm_size (mpicom, npes, ier)
285 4608 : allocate ( displs(npes) )
286 3072 : allocate ( lengths(npes) )
287 3072 : allocate ( proc_name(max_len) )
288 3072 : allocate ( proc_names(max_len*npes) )
289 :
290 : !
291 : ! Get processor names and send to root.
292 : !
293 1536 : call mpi_get_processor_name (tmp_name, length, ier)
294 196608 : proc_name(:) = ' '
295 12288 : do i = 1, length
296 12288 : proc_name(i) = tmp_name(i:i)
297 : end do
298 :
299 149816832 : proc_names(:) = ' '
300 1181184 : lengths(:) = max_len
301 1181184 : do i=1,npes
302 1181184 : displs(i) = (i-1)*max_len
303 : enddo
304 : call fc_gathervc (proc_name, max_len, mpichar, &
305 : proc_names, lengths, displs, mpichar, &
306 1536 : 0, mpicom, flow_cntl=-1)
307 1536 : if (masterproc) then
308 2 : write(iulog,*) npes, 'pes participating in computation'
309 2 : write(iulog,*) '-----------------------------------'
310 2 : write(iulog,*) 'TASK# NAME'
311 516 : do i=0,min(npes-1,256) ! dont print too many of these
312 65792 : do c=1,max_len
313 65792 : tmp_name(c:c) = proc_names(i*max_len+c)
314 : enddo
315 516 : write(iulog,'(i3,2x,a)') i,trim(tmp_name)
316 : end do
317 2 : if(npes-1>256) then
318 2 : write(iulog,*) '... list truncated at 256'
319 : end if
320 : end if
321 : !
322 : ! Identify SMP nodes and process/SMP mapping.
323 : ! (Assume that processor names are SMP node names on SMP clusters.)
324 : !
325 4608 : allocate ( proc_smp_map(0:npes-1) )
326 1536 : if (masterproc) then
327 6 : allocate ( smp_names(0:npes-1) )
328 1538 : smp_names(:) = ' '
329 1538 : proc_smp_map(:) = -1
330 : !
331 2 : nsmps = 1
332 256 : do c=1,max_len
333 256 : tmp_name(c:c) = proc_names(c)
334 : enddo
335 2 : smp_names(0) = trim(tmp_name)
336 2 : proc_smp_map(0) = 0
337 : !
338 1536 : do i=1,npes-1
339 196352 : do c=1,max_len
340 196352 : tmp_name(c:c) = proc_names(i*max_len+c)
341 : enddo
342 :
343 : j = 0
344 : done = .false.
345 6898 : do while ((.not. done) .and. (j < nsmps))
346 5364 : if (smp_names(j) .eq. trim(tmp_name)) then
347 1524 : proc_smp_map(i) = j
348 1524 : done = .true.
349 : endif
350 5364 : j = j + 1
351 : enddo
352 :
353 1536 : if (.not. done) then
354 10 : smp_names(nsmps) = trim(tmp_name)
355 10 : proc_smp_map(i) = nsmps
356 10 : nsmps = nsmps + 1
357 : endif
358 :
359 : enddo
360 2 : deallocate(smp_names)
361 : endif
362 1536 : call mpibcast(nsmps, 1, mpiint, 0, mpicom)
363 1536 : call mpibcast(proc_smp_map, npes, mpiint, 0, mpicom)
364 : !
365 1536 : deallocate(displs)
366 1536 : deallocate(lengths)
367 1536 : deallocate(proc_name)
368 1536 : deallocate(proc_names)
369 :
370 : ! Create a type for transferring column information
371 1536 : allocate(lengths(6))
372 10752 : lengths(:) = 1
373 10752 : origtypes(:) = MPI_INTEGER
374 1536 : h1 = 0
375 1536 : h1 = h1 + 1
376 : call MPI_Get_address(dummy_loc(1)%source_task, offsets(h1), ierr)
377 1536 : h1 = h1 + 1
378 1536 : call MPI_Get_address(dummy_loc(1)%source_index, offsets(h1), ierr)
379 1536 : h1 = h1 + 1
380 1536 : call MPI_Get_address(dummy_loc(1)%dest_task, offsets(h1), ierr)
381 1536 : h1 = h1 + 1
382 1536 : call MPI_Get_address(dummy_loc(1)%dest_index, offsets(h1), ierr)
383 1536 : h1 = h1 + 1
384 1536 : call MPI_Get_address(dummy_loc(1)%mpi_tag, offsets(h1), ierr)
385 9216 : do hind = h1, 1, -1
386 9216 : offsets(hind) = offsets(hind) - offsets(1)
387 : end do
388 0 : call MPI_type_create_struct(h1, lengths(1:h1), offsets(1:h1), &
389 1536 : origtypes(1:h1), col_trans_type_temp, ierr)
390 : ! Adjust for padding
391 1536 : call MPI_Get_address(dummy_loc(1)%source_task, offsets(1), ierr)
392 1536 : call MPI_Get_address(dummy_loc(2)%source_task, offsets(2), ierr)
393 1536 : extent = offsets(2) - offsets(1)
394 : call MPI_type_create_resized(col_trans_type_temp, 0_MPI_ADDRESS_KIND, &
395 1536 : extent, spmd_col_trans_mpi_type, ierr)
396 1536 : call MPI_type_commit(spmd_col_trans_mpi_type, ierr)
397 1536 : deallocate(lengths)
398 :
399 : #else
400 : !
401 : ! spmd is not defined
402 : !
403 : mpicom = mpicom_atm
404 : iam = 0
405 : masterprocid = 0
406 : masterproc = .true.
407 : npes = 1
408 : nsmps = 1
409 : allocate ( proc_smp_map(0:0) )
410 : proc_smp_map(:) = -1
411 :
412 : #endif
413 :
414 9216 : end subroutine spmdinit
415 :
416 : #if (defined SPMD)
417 : !
418 : !========================================================================
419 : !
420 0 : subroutine swapm (steps, nprocs, swapids, &
421 0 : sndbuf, sbuf_siz, sndlths, sdispls, &
422 0 : rcvbuf, rbuf_siz, rcvlths, rdispls, &
423 : comm, comm_protocol, comm_maxreq )
424 :
425 : !-----------------------------------------------------------------------
426 : !
427 : ! Purpose:
428 : ! Reduced version of original swapm (for swap of multiple messages
429 : ! using MPI point-to-point routines), more efficiently implementing a
430 : ! subset of the swap protocols.
431 : !
432 : ! Method:
433 : ! comm_protocol:
434 : ! = 3 or 5: use nonblocking send
435 : ! = 2 or 4: use blocking send
436 : ! = 4 or 5: use handshaking protocol
437 : ! comm_maxreq:
438 : ! =-1,0: do not limit number of outstanding send/receive requests
439 : ! >0: do not allow more than min(comm_maxreq, steps) outstanding
440 : ! nonblocking send requests or nonblocking receive requests
441 : !
442 : ! Author of original version: P. Worley
443 : ! Ported to CAM: P. Worley, December 2003
444 : ! Simplified version: P. Worley, October, 2008
445 : !
446 : !-----------------------------------------------------------------------
447 :
448 : !-----------------------------------------------------------------------
449 : implicit none
450 : !---------------------------Input arguments--------------------------
451 : !
452 : integer, intent(in) :: steps ! number of swaps to initiate
453 : integer, intent(in) :: nprocs ! size of communicator
454 : integer, intent(in) :: sbuf_siz ! size of send buffer
455 : integer, intent(in) :: rbuf_siz ! size of receive buffer
456 : integer, intent(in) :: swapids(steps) ! MPI process id of swap partners
457 :
458 : integer, intent(in) :: sndlths(0:nprocs-1)! length of outgoing message
459 : integer, intent(in) :: sdispls(0:nprocs-1)! offset from beginning of send
460 : ! buffer where outgoing messages
461 : ! should be sent from
462 : integer, intent(in) :: rcvlths(0:nprocs-1)! length of incoming messages
463 : integer, intent(in) :: rdispls(0:nprocs-1)! offset from beginning of receive
464 : ! buffer where incoming messages
465 : ! should be placed
466 : real(r8), intent(in) :: sndbuf(sbuf_siz) ! outgoing message buffer
467 : real(r8), intent(out) :: rcvbuf(rbuf_siz) ! incoming message buffer
468 :
469 : integer, intent(in) :: comm ! MPI communicator
470 : integer, intent(in) :: comm_protocol ! swap_comm protocol
471 : integer, intent(in) :: comm_maxreq ! maximum number of outstanding
472 : ! nonblocking requests
473 :
474 : !
475 : !---------------------------Local workspace-----------------------------
476 : !
477 : integer :: p ! process index
478 : integer :: istep ! loop index
479 : integer :: offset_s ! index of message beginning in
480 : ! send buffer
481 : integer :: offset_r ! index of message beginning in
482 : ! receive buffer
483 0 : integer :: sndids(steps) ! send request ids
484 0 : integer :: rcvids(steps) ! receive request ids
485 0 : integer :: hs_rcvids(steps) ! handshake receive request ids
486 :
487 : integer :: maxreq, maxreqh ! maximum number of outstanding
488 : ! nonblocking requests (and half)
489 0 : integer :: hs_s, hs_r(steps) ! handshake variables (send/receive)
490 : integer :: rstep ! "receive" step index
491 :
492 : logical :: handshake, sendd ! protocol option flags
493 :
494 : integer :: ier ! return error status
495 : integer :: status(MPI_STATUS_SIZE) ! MPI status
496 : !
497 : !-------------------------------------------------------------------------------------
498 : !
499 0 : if (steps .eq. 0) return
500 :
501 : ! identify communication protocol
502 0 : if ((comm_protocol < 2) .or. (comm_protocol > 5)) then
503 : sendd = .true.
504 : handshake = .true.
505 : else
506 0 : if ((comm_protocol .eq. 4) .or. (comm_protocol .eq. 5)) then
507 : handshake = .true.
508 : else
509 0 : handshake = .false.
510 : endif
511 :
512 0 : if ((comm_protocol .eq. 2) .or. (comm_protocol .eq. 4)) then
513 : sendd = .true.
514 : else
515 0 : sendd = .false.
516 : endif
517 : endif
518 :
519 : ! identify maximum number of outstanding nonblocking requests to permit
520 0 : if (steps .eq. 1) then
521 : maxreq = 1
522 : maxreqh = 1
523 : else
524 0 : if (comm_maxreq >= -1) then
525 : maxreq = comm_maxreq
526 : else
527 0 : maxreq = steps
528 : endif
529 :
530 0 : if ((maxreq .le. steps) .and. (maxreq > 0)) then
531 0 : if (maxreq > 1) then
532 0 : maxreqh = maxreq/2
533 : else
534 : maxreq = 2
535 : maxreqh = 1
536 : endif
537 : else
538 : maxreq = steps
539 : maxreqh = steps
540 : endif
541 : endif
542 :
543 : ! Four protocol options:
544 : ! (1) handshaking + blocking sends
545 0 : if ((handshake) .and. (sendd)) then
546 :
547 : ! Initialize handshake variable
548 0 : hs_s = 1
549 :
550 : ! Post initial handshake receive requests
551 0 : do istep=1,maxreq
552 0 : p = swapids(istep)
553 0 : if (sndlths(p) > 0) then
554 : call mpi_irecv( hs_r(istep), 1, mpiint, p, iam, comm, &
555 0 : hs_rcvids(istep), ier )
556 : endif
557 : enddo
558 :
559 : ! Post initial receive requests
560 0 : do istep=1,maxreq
561 0 : p = swapids(istep)
562 0 : if (rcvlths(p) > 0) then
563 0 : offset_r = rdispls(p)+1
564 0 : call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
565 0 : comm, rcvids(istep), ier )
566 0 : call mpi_send ( hs_s, 1, mpiint, p, p, comm, ier )
567 : endif
568 : enddo
569 : rstep = maxreq
570 :
571 : ! Send (and start receiving) data
572 0 : do istep=1,steps
573 0 : p = swapids(istep)
574 :
575 : ! Submit new rsend request
576 0 : if (sndlths(p) > 0) then
577 0 : offset_s = sdispls(p)+1
578 : call mpi_wait ( hs_rcvids(istep), MPI_STATUS_IGNORE, ier )
579 0 : call mpi_rsend ( sndbuf(offset_s), sndlths(p), mpir8, p, iam, &
580 0 : comm, ier )
581 : endif
582 :
583 0 : if (istep > maxreqh) then
584 :
585 : ! Wait for oldest irecv request to complete
586 0 : p = swapids(istep-maxreqh)
587 0 : if (rcvlths(p) > 0) then
588 : call mpi_wait( rcvids(istep-maxreqh), status, ier )
589 : endif
590 :
591 0 : if (rstep < steps) then
592 0 : rstep = rstep + 1
593 0 : p = swapids(rstep)
594 :
595 : ! Submit a new handshake irecv request
596 0 : if (sndlths(p) > 0) then
597 : call mpi_irecv( hs_r(rstep), 1, mpiint, p, iam, comm, &
598 0 : hs_rcvids(rstep), ier )
599 : endif
600 :
601 : ! Submit a new irecv request
602 0 : if (rcvlths(p) > 0) then
603 0 : offset_r = rdispls(p)+1
604 0 : call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
605 0 : comm, rcvids(rstep), ier )
606 0 : call mpi_send ( hs_s, 1, mpiint, p, p, comm, ier )
607 : endif
608 : endif
609 :
610 : endif
611 : !
612 : enddo
613 :
614 : ! wait for rest of receive requests to complete
615 0 : do istep=steps-maxreqh+1,steps
616 0 : p = swapids(istep)
617 0 : if (rcvlths(p) > 0) then
618 : call mpi_wait( rcvids(istep), status, ier )
619 : endif
620 : enddo
621 :
622 : ! (2) handshaking + nonblocking sends
623 0 : elseif ((handshake) .and. (.not. sendd)) then
624 :
625 : ! Initialize handshake variable
626 0 : hs_s = 1
627 :
628 : ! Post initial handshake receive requests
629 0 : do istep=1,maxreq
630 0 : p = swapids(istep)
631 0 : if (sndlths(p) > 0) then
632 : call mpi_irecv( hs_r(istep), 1, mpiint, p, iam, comm, &
633 0 : hs_rcvids(istep), ier )
634 : endif
635 : enddo
636 :
637 : ! Post initial receive requests
638 0 : do istep=1,maxreq
639 0 : p = swapids(istep)
640 0 : if (rcvlths(p) > 0) then
641 0 : offset_r = rdispls(p)+1
642 0 : call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
643 0 : comm, rcvids(istep), ier )
644 0 : call mpi_send ( hs_s, 1, mpiint, p, p, comm, ier )
645 : endif
646 : enddo
647 : rstep = maxreq
648 :
649 : ! Send (and start receiving) data
650 0 : do istep=1,steps
651 0 : p = swapids(istep)
652 :
653 : ! Submit new irsend request
654 0 : if (sndlths(p) > 0) then
655 0 : offset_s = sdispls(p)+1
656 : call mpi_wait ( hs_rcvids(istep), MPI_STATUS_IGNORE, ier )
657 0 : call mpi_irsend( sndbuf(offset_s), sndlths(p), mpir8, p, iam, &
658 0 : comm, sndids(istep), ier )
659 : endif
660 :
661 0 : if (istep > maxreqh) then
662 :
663 : ! Wait for oldest irecv request to complete
664 0 : p = swapids(istep-maxreqh)
665 0 : if (rcvlths(p) > 0) then
666 : call mpi_wait( rcvids(istep-maxreqh), status, ier )
667 : endif
668 :
669 0 : if (rstep < steps) then
670 0 : rstep = rstep + 1
671 0 : p = swapids(rstep)
672 :
673 : ! Submit a new handshake irecv request
674 0 : if (sndlths(p) > 0) then
675 : call mpi_irecv( hs_r(rstep), 1, mpiint, p, iam, comm, &
676 0 : hs_rcvids(rstep), ier )
677 : endif
678 :
679 : ! Submit a new irecv request
680 0 : if (rcvlths(p) > 0) then
681 0 : offset_r = rdispls(p)+1
682 0 : call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
683 0 : comm, rcvids(rstep), ier )
684 0 : call mpi_send ( hs_s, 1, mpiint, p, p, comm, ier )
685 : endif
686 : endif
687 :
688 : ! Wait for outstanding i(r)send request to complete
689 0 : p = swapids(istep-maxreqh)
690 0 : if (sndlths(p) > 0) then
691 : call mpi_wait( sndids(istep-maxreqh), status, ier )
692 : endif
693 :
694 : endif
695 :
696 : enddo
697 :
698 : ! wait for rest of send and receive requests to complete
699 0 : do istep=steps-maxreqh+1,steps
700 0 : p = swapids(istep)
701 0 : if (rcvlths(p) > 0) then
702 : call mpi_wait( rcvids(istep), status, ier )
703 : endif
704 0 : if (sndlths(p) > 0) then
705 : call mpi_wait( sndids(istep), status, ier )
706 : endif
707 : enddo
708 :
709 : ! (3) no handshaking + blocking sends
710 0 : elseif ((.not. handshake) .and. (sendd)) then
711 :
712 : ! Post receive requests
713 0 : do istep=1,maxreq
714 0 : p = swapids(istep)
715 0 : if (rcvlths(p) > 0) then
716 0 : offset_r = rdispls(p)+1
717 0 : call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
718 0 : comm, rcvids(istep), ier )
719 : endif
720 : enddo
721 : rstep = maxreq
722 :
723 : ! Send (and start receiving) data
724 0 : do istep=1,steps
725 0 : p = swapids(istep)
726 :
727 : ! Submit new send request
728 0 : if (sndlths(p) > 0) then
729 0 : offset_s = sdispls(p)+1
730 0 : call mpi_send( sndbuf(offset_s), sndlths(p), mpir8, p, iam, &
731 0 : comm, ier )
732 : endif
733 :
734 0 : if (istep > maxreqh) then
735 :
736 : ! Wait for oldest irecv request to complete
737 0 : p = swapids(istep-maxreqh)
738 0 : if (rcvlths(p) > 0) then
739 : call mpi_wait( rcvids(istep-maxreqh), status, ier )
740 : endif
741 :
742 : ! Submit a new irecv request
743 0 : if (rstep < steps) then
744 0 : rstep = rstep + 1
745 0 : p = swapids(rstep)
746 0 : if (rcvlths(p) > 0) then
747 0 : offset_r = rdispls(p)+1
748 0 : call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
749 0 : comm, rcvids(rstep), ier )
750 : endif
751 : endif
752 :
753 : endif
754 :
755 : enddo
756 :
757 : ! wait for rest of send and receive requests to complete
758 0 : do istep=steps-maxreqh+1,steps
759 0 : p = swapids(istep)
760 0 : if (rcvlths(p) > 0) then
761 : call mpi_wait( rcvids(istep), status, ier )
762 : endif
763 : enddo
764 :
765 : ! (4) no handshaking + nonblocking sends
766 0 : elseif ((.not. handshake) .and. (.not. sendd)) then
767 :
768 : ! Post receive requests
769 0 : do istep=1,maxreq
770 0 : p = swapids(istep)
771 0 : if (rcvlths(p) > 0) then
772 0 : offset_r = rdispls(p)+1
773 0 : call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
774 0 : comm, rcvids(istep), ier )
775 : endif
776 : enddo
777 : rstep = maxreq
778 :
779 : ! Send (and start receiving) data
780 0 : do istep=1,steps
781 0 : p = swapids(istep)
782 :
783 : ! Submit new isend request
784 0 : if (sndlths(p) > 0) then
785 0 : offset_s = sdispls(p)+1
786 0 : call mpi_isend( sndbuf(offset_s), sndlths(p), mpir8, p, iam, &
787 0 : comm, sndids(istep), ier )
788 : endif
789 :
790 0 : if (istep > maxreqh) then
791 :
792 : ! Wait for oldest irecv request to complete
793 0 : p = swapids(istep-maxreqh)
794 0 : if (rcvlths(p) > 0) then
795 : call mpi_wait( rcvids(istep-maxreqh), status, ier )
796 : endif
797 :
798 : ! Submit a new irecv request
799 0 : if (rstep < steps) then
800 0 : rstep = rstep + 1
801 0 : p = swapids(rstep)
802 0 : if (rcvlths(p) > 0) then
803 0 : offset_r = rdispls(p)+1
804 0 : call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
805 0 : comm, rcvids(rstep), ier )
806 : endif
807 : endif
808 :
809 : ! Wait for outstanding i(r)send request to complete
810 0 : p = swapids(istep-maxreqh)
811 0 : if (sndlths(p) > 0) then
812 : call mpi_wait( sndids(istep-maxreqh), status, ier )
813 : endif
814 :
815 : endif
816 :
817 : enddo
818 :
819 : ! wait for rest of send and receive requests to complete
820 0 : do istep=steps-maxreqh+1,steps
821 0 : p = swapids(istep)
822 0 : if (rcvlths(p) > 0) then
823 : call mpi_wait( rcvids(istep), status, ier )
824 : endif
825 0 : if (sndlths(p) > 0) then
826 : call mpi_wait( sndids(istep), status, ier )
827 : endif
828 : enddo
829 :
830 : endif
831 :
832 : return
833 :
834 : end subroutine swapm
835 : !
836 : !========================================================================
837 :
838 : !-----------------------------------------------------------------------
839 : !
840 : ! Purpose: gather collective with additional flow control, so as to
841 : ! be more robust when used with high process counts.
842 : ! If flow_cntl optional parameter
843 : ! < 0: use MPI_Gather
844 : ! >= 0: use point-to-point with handshaking messages and
845 : ! preposting receive requests up to
846 : ! min(max(1,flow_cntl),max_gather_block_size)
847 : ! ahead if optional flow_cntl parameter is present.
848 : ! Otherwise, fc_gather_flow_cntl is used in its place.
849 : ! Default value is 64.
850 : !
851 : ! Entry points:
852 : ! fc_gatherv functionally equivalent to mpi_gatherv
853 : ! fc_gathervr4 functionally equivalent to mpi_gatherv for real*4 data
854 : ! fc_gathervint functionally equivalent to mpi_gatherv for integer data
855 : ! fc_gathervc functionally equivalent to mpi_gatherv for character data
856 : !
857 : ! Author: P. Worley
858 : !-----------------------------------------------------------------------
859 :
860 : !
861 : !========================================================================
862 : !
863 0 : subroutine fc_gatherv (sendbuf, sendcnt, sendtype, &
864 : recvbuf, recvcnts, displs, recvtype, &
865 : root, comm, flow_cntl )
866 : !
867 : ! Collects different messages from each process on masterproc
868 : !
869 : use shr_kind_mod, only: r8 => shr_kind_r8
870 : use mpishorthand
871 : use cam_abortutils, only: endrun
872 : use cam_logfile, only: iulog
873 :
874 : #if defined( WRAP_MPI_TIMING )
875 : use perf_mod
876 : #endif
877 :
878 : implicit none
879 :
880 : real (r8), intent(in) :: sendbuf(*)
881 : real (r8), intent(out) :: recvbuf(*)
882 : integer, intent(in) :: displs(*)
883 : integer, intent(in) :: sendcnt
884 : integer, intent(in) :: sendtype
885 : integer, intent(in) :: recvcnts(*)
886 : integer, intent(in) :: recvtype
887 : integer, intent(in) :: root
888 : integer, intent(in) :: comm
889 : integer, optional, intent(in) :: flow_cntl
890 :
891 : real (r8) :: signal
892 : logical fc_gather ! use explicit flow control?
893 : integer gather_block_size ! number of preposted receive requests
894 :
895 : integer :: mytid, mysize, mtag, p, q, i, count
896 : integer :: preposts, head, tail
897 : integer :: rcvid(max_gather_block_size)
898 : integer :: status(MPI_STATUS_SIZE)
899 : integer ier ! MPI error code
900 :
901 0 : if ( present(flow_cntl) ) then
902 0 : if (flow_cntl >= 0) then
903 0 : gather_block_size = min(max(1,flow_cntl),max_gather_block_size)
904 : fc_gather = .true.
905 : else
906 : fc_gather = .false.
907 : endif
908 : else
909 0 : if (fc_gather_flow_cntl >= 0) then
910 0 : gather_block_size = min(max(1,fc_gather_flow_cntl),max_gather_block_size)
911 : fc_gather = .true.
912 : else
913 : fc_gather = .false.
914 : endif
915 : endif
916 :
917 : if (fc_gather) then
918 :
919 : #if defined( WRAP_MPI_TIMING )
920 : call t_startf ('fc_gatherv_r8')
921 : #endif
922 0 : call mpi_comm_rank (comm, mytid, ier)
923 0 : call mpi_comm_size (comm, mysize, ier)
924 0 : mtag = 0
925 0 : if (root .eq. mytid) then
926 :
927 : ! prepost gather_block_size irecvs, and start receiving data
928 0 : preposts = min(mysize-1, gather_block_size)
929 0 : head = 0
930 0 : count = 0
931 0 : do p=0, mysize-1
932 0 : if (p .ne. root) then
933 0 : q = p+1
934 0 : if (recvcnts(q) > 0) then
935 0 : count = count + 1
936 0 : if (count > preposts) then
937 0 : tail = mod(head,preposts) + 1
938 0 : call mpi_wait (rcvid(tail), status, ier)
939 : end if
940 0 : head = mod(head,preposts) + 1
941 0 : call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), &
942 0 : recvtype, p, mtag, comm, rcvid(head), &
943 0 : ier )
944 0 : call mpi_send ( signal, 1, mpir8, p, mtag, comm, ier )
945 : end if
946 : end if
947 : end do
948 :
949 : ! copy local data
950 0 : q = mytid+1
951 0 : do i=1,sendcnt
952 0 : recvbuf(displs(q)+i) = sendbuf(i)
953 : enddo
954 :
955 : ! wait for final data
956 0 : do i=1,min(count,preposts)
957 0 : call mpi_wait (rcvid(i), status, ier)
958 : enddo
959 :
960 : else
961 :
962 0 : if (sendcnt > 0) then
963 : call mpi_recv ( signal, 1, mpir8, root, mtag, comm, &
964 0 : status, ier )
965 : call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, &
966 0 : comm, ier )
967 : end if
968 :
969 : endif
970 0 : if (ier /= mpi_success) then
971 0 : write(iulog,*)'fc_gatherv_r8 failed ier=',ier
972 0 : call endrun
973 : end if
974 : #if defined( WRAP_MPI_TIMING )
975 : call t_stopf ('fc_gatherv_r8')
976 : #endif
977 :
978 : else
979 :
980 : #if defined( WRAP_MPI_TIMING )
981 : call t_startf ('mpi_gatherv')
982 : #endif
983 : call mpi_gatherv (sendbuf, sendcnt, sendtype, &
984 : recvbuf, recvcnts, displs, recvtype, &
985 0 : root, comm, ier)
986 0 : if (ier /= mpi_success) then
987 0 : write(iulog,*)'mpi_gatherv failed ier=',ier
988 0 : call endrun
989 : end if
990 : #if defined( WRAP_MPI_TIMING )
991 : call t_stopf ('mpi_gatherv')
992 : #endif
993 :
994 : endif
995 :
996 0 : return
997 : end subroutine fc_gatherv
998 : !
999 : !========================================================================
1000 : !
1001 0 : subroutine fc_gathervr4 (sendbuf, sendcnt, sendtype, &
1002 : recvbuf, recvcnts, displs, recvtype, &
1003 : root, comm, flow_cntl )
1004 : !
1005 : ! Collects different messages from each process on masterproc
1006 : !
1007 : use shr_kind_mod, only: r4 => shr_kind_r4, r8 => shr_kind_r8
1008 : use mpishorthand
1009 : use cam_abortutils, only: endrun
1010 : use cam_logfile, only: iulog
1011 :
1012 : #if defined( WRAP_MPI_TIMING )
1013 : use perf_mod
1014 : #endif
1015 :
1016 : implicit none
1017 :
1018 : real (r4), intent(in) :: sendbuf(*)
1019 : real (r4), intent(out) :: recvbuf(*)
1020 : integer, intent(in) :: displs(*)
1021 : integer, intent(in) :: sendcnt
1022 : integer, intent(in) :: sendtype
1023 : integer, intent(in) :: recvcnts(*)
1024 : integer, intent(in) :: recvtype
1025 : integer, intent(in) :: root
1026 : integer, intent(in) :: comm
1027 : integer, optional, intent(in) :: flow_cntl
1028 :
1029 : real (r8) :: signal
1030 : logical fc_gather ! use explicit flow control?
1031 : integer gather_block_size ! number of preposted receive requests
1032 :
1033 : integer :: mytid, mysize, mtag, p, q, i, count
1034 : integer :: preposts, head, tail
1035 : integer :: rcvid(max_gather_block_size)
1036 : integer :: status(MPI_STATUS_SIZE)
1037 : integer ier ! MPI error code
1038 :
1039 0 : if ( present(flow_cntl) ) then
1040 0 : if (flow_cntl >= 0) then
1041 0 : gather_block_size = min(max(1,flow_cntl),max_gather_block_size)
1042 : fc_gather = .true.
1043 : else
1044 : fc_gather = .false.
1045 : endif
1046 : else
1047 0 : if (fc_gather_flow_cntl >= 0) then
1048 0 : gather_block_size = min(max(1,fc_gather_flow_cntl),max_gather_block_size)
1049 : fc_gather = .true.
1050 : else
1051 : fc_gather = .false.
1052 : endif
1053 : endif
1054 :
1055 : if (fc_gather) then
1056 :
1057 : #if defined( WRAP_MPI_TIMING )
1058 : call t_startf ('fc_gatherv_r4')
1059 : #endif
1060 0 : call mpi_comm_rank (comm, mytid, ier)
1061 0 : call mpi_comm_size (comm, mysize, ier)
1062 0 : mtag = 0
1063 0 : if (root .eq. mytid) then
1064 :
1065 : ! prepost gather_block_size irecvs, and start receiving data
1066 0 : preposts = min(mysize-1, gather_block_size)
1067 0 : head = 0
1068 0 : count = 0
1069 0 : do p=0, mysize-1
1070 0 : if (p .ne. root) then
1071 0 : q = p+1
1072 0 : if (recvcnts(q) > 0) then
1073 0 : count = count + 1
1074 0 : if (count > preposts) then
1075 0 : tail = mod(head,preposts) + 1
1076 0 : call mpi_wait (rcvid(tail), status, ier)
1077 : end if
1078 0 : head = mod(head,preposts) + 1
1079 0 : call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), &
1080 0 : recvtype, p, mtag, comm, rcvid(head), &
1081 0 : ier )
1082 0 : call mpi_send ( signal, 1, mpir8, p, mtag, comm, ier )
1083 : end if
1084 : end if
1085 : end do
1086 :
1087 : ! copy local data
1088 0 : q = mytid+1
1089 0 : do i=1,sendcnt
1090 0 : recvbuf(displs(q)+i) = sendbuf(i)
1091 : enddo
1092 :
1093 : ! wait for final data
1094 0 : do i=1,min(count,preposts)
1095 0 : call mpi_wait (rcvid(i), status, ier)
1096 : enddo
1097 :
1098 : else
1099 :
1100 0 : if (sendcnt > 0) then
1101 : call mpi_recv ( signal, 1, mpir8, root, mtag, comm, &
1102 0 : status, ier )
1103 : call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, &
1104 0 : comm, ier )
1105 : end if
1106 :
1107 : endif
1108 0 : if (ier /= mpi_success) then
1109 0 : write(iulog,*)'fc_gatherv_r4 failed ier=',ier
1110 0 : call endrun
1111 : end if
1112 : #if defined( WRAP_MPI_TIMING )
1113 : call t_stopf ('fc_gatherv_r4')
1114 : #endif
1115 :
1116 : else
1117 :
1118 : #if defined( WRAP_MPI_TIMING )
1119 : call t_startf ('mpi_gatherv')
1120 : #endif
1121 : call mpi_gatherv (sendbuf, sendcnt, sendtype, &
1122 : recvbuf, recvcnts, displs, recvtype, &
1123 0 : root, comm, ier)
1124 0 : if (ier /= mpi_success) then
1125 0 : write(iulog,*)'mpi_gatherv failed ier=',ier
1126 0 : call endrun
1127 : end if
1128 : #if defined( WRAP_MPI_TIMING )
1129 : call t_stopf ('mpi_gatherv')
1130 : #endif
1131 :
1132 : endif
1133 :
1134 0 : return
1135 : end subroutine fc_gathervr4
1136 : !
1137 : !========================================================================
1138 : !
1139 0 : subroutine fc_gathervint (sendbuf, sendcnt, sendtype, &
1140 : recvbuf, recvcnts, displs, recvtype, &
1141 : root, comm, flow_cntl )
1142 : !
1143 : ! Collects different messages from each process on masterproc
1144 : !
1145 : use shr_kind_mod, only: r8 => shr_kind_r8
1146 : use mpishorthand
1147 : use cam_abortutils, only: endrun
1148 : use cam_logfile, only: iulog
1149 :
1150 : #if defined( WRAP_MPI_TIMING )
1151 : use perf_mod
1152 : #endif
1153 :
1154 : implicit none
1155 :
1156 : integer, intent(in) :: sendbuf(*)
1157 : integer, intent(out) :: recvbuf(*)
1158 : integer, intent(in) :: displs(*)
1159 : integer, intent(in) :: sendcnt
1160 : integer, intent(in) :: sendtype
1161 : integer, intent(in) :: recvcnts(*)
1162 : integer, intent(in) :: recvtype
1163 : integer, intent(in) :: root
1164 : integer, intent(in) :: comm
1165 : integer, optional, intent(in) :: flow_cntl
1166 :
1167 : real (r8) :: signal
1168 : logical fc_gather ! use explicit flow control?
1169 : integer gather_block_size ! number of preposted receive requests
1170 :
1171 : integer :: mytid, mysize, mtag, p, q, i, count
1172 : integer :: preposts, head, tail
1173 : integer :: rcvid(max_gather_block_size)
1174 : integer :: status(MPI_STATUS_SIZE)
1175 : integer ier ! MPI error code
1176 :
1177 0 : if ( present(flow_cntl) ) then
1178 0 : if (flow_cntl >= 0) then
1179 0 : gather_block_size = min(max(1,flow_cntl),max_gather_block_size)
1180 : fc_gather = .true.
1181 : else
1182 : fc_gather = .false.
1183 : endif
1184 : else
1185 0 : if (fc_gather_flow_cntl >= 0) then
1186 0 : gather_block_size = min(max(1,fc_gather_flow_cntl),max_gather_block_size)
1187 : fc_gather = .true.
1188 : else
1189 : fc_gather = .false.
1190 : endif
1191 : endif
1192 :
1193 : if (fc_gather) then
1194 :
1195 : #if defined( WRAP_MPI_TIMING )
1196 : call t_startf ('fc_gatherv_int')
1197 : #endif
1198 0 : call mpi_comm_rank (comm, mytid, ier)
1199 0 : call mpi_comm_size (comm, mysize, ier)
1200 0 : mtag = 0
1201 0 : if (root .eq. mytid) then
1202 :
1203 : ! prepost gather_block_size irecvs, and start receiving data
1204 0 : preposts = min(mysize-1, gather_block_size)
1205 0 : head = 0
1206 0 : count = 0
1207 0 : do p=0, mysize-1
1208 0 : if (p .ne. root) then
1209 0 : q = p+1
1210 0 : if (recvcnts(q) > 0) then
1211 0 : count = count + 1
1212 0 : if (count > preposts) then
1213 0 : tail = mod(head,preposts) + 1
1214 0 : call mpi_wait (rcvid(tail), status, ier)
1215 : end if
1216 0 : head = mod(head,preposts) + 1
1217 0 : call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), &
1218 0 : recvtype, p, mtag, comm, rcvid(head), &
1219 0 : ier )
1220 0 : call mpi_send ( signal, 1, mpir8, p, mtag, comm, ier )
1221 : end if
1222 : end if
1223 : end do
1224 :
1225 : ! copy local data
1226 0 : q = mytid+1
1227 0 : do i=1,sendcnt
1228 0 : recvbuf(displs(q)+i) = sendbuf(i)
1229 : enddo
1230 :
1231 : ! wait for final data
1232 0 : do i=1,min(count,preposts)
1233 0 : call mpi_wait (rcvid(i), status, ier)
1234 : enddo
1235 :
1236 : else
1237 :
1238 0 : if (sendcnt > 0) then
1239 : call mpi_recv ( signal, 1, mpir8, root, mtag, comm, &
1240 0 : status, ier )
1241 : call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, &
1242 0 : comm, ier )
1243 : end if
1244 :
1245 : endif
1246 0 : if (ier /= mpi_success) then
1247 0 : write(iulog,*)'fc_gatherv_int failed ier=',ier
1248 0 : call endrun
1249 : end if
1250 : #if defined( WRAP_MPI_TIMING )
1251 : call t_stopf ('fc_gatherv_int')
1252 : #endif
1253 :
1254 : else
1255 :
1256 : #if defined( WRAP_MPI_TIMING )
1257 : call t_startf ('mpi_gatherv')
1258 : #endif
1259 : call mpi_gatherv (sendbuf, sendcnt, sendtype, &
1260 : recvbuf, recvcnts, displs, recvtype, &
1261 0 : root, comm, ier)
1262 0 : if (ier /= mpi_success) then
1263 0 : write(iulog,*)'mpi_gatherv failed ier=',ier
1264 0 : call endrun
1265 : end if
1266 : #if defined( WRAP_MPI_TIMING )
1267 : call t_stopf ('mpi_gatherv')
1268 : #endif
1269 :
1270 : endif
1271 :
1272 0 : return
1273 : end subroutine fc_gathervint
1274 : !
1275 : !========================================================================
1276 : !
1277 1536 : subroutine fc_gathervc (sendbuf, sendcnt, sendtype, &
1278 : recvbuf, recvcnts, displs, recvtype, &
1279 : root, comm, flow_cntl )
1280 : !
1281 : ! Collects different messages from each process on masterproc
1282 : !
1283 : use shr_kind_mod, only: r8 => shr_kind_r8
1284 : use mpishorthand
1285 : use cam_abortutils, only: endrun
1286 : use cam_logfile, only: iulog
1287 :
1288 : #if defined( WRAP_MPI_TIMING )
1289 : use perf_mod
1290 : #endif
1291 :
1292 : implicit none
1293 :
1294 : character, intent(in) :: sendbuf(*)
1295 : character, intent(out) :: recvbuf(*)
1296 : integer, intent(in) :: displs(*)
1297 : integer, intent(in) :: sendcnt
1298 : integer, intent(in) :: sendtype
1299 : integer, intent(in) :: recvcnts(*)
1300 : integer, intent(in) :: recvtype
1301 : integer, intent(in) :: root
1302 : integer, intent(in) :: comm
1303 : integer, optional, intent(in) :: flow_cntl
1304 :
1305 : real (r8) :: signal
1306 : logical fc_gather ! use explicit flow control?
1307 : integer gather_block_size ! number of preposted receive requests
1308 :
1309 : integer :: mytid, mysize, mtag, p, q, i, count
1310 : integer :: preposts, head, tail
1311 : integer :: rcvid(max_gather_block_size)
1312 : integer :: status(MPI_STATUS_SIZE)
1313 : integer ier ! MPI error code
1314 :
1315 1536 : if ( present(flow_cntl) ) then
1316 1536 : if (flow_cntl >= 0) then
1317 0 : gather_block_size = min(max(1,flow_cntl),max_gather_block_size)
1318 : fc_gather = .true.
1319 : else
1320 : fc_gather = .false.
1321 : endif
1322 : else
1323 0 : if (fc_gather_flow_cntl >= 0) then
1324 0 : gather_block_size = min(max(1,fc_gather_flow_cntl),max_gather_block_size)
1325 : fc_gather = .true.
1326 : else
1327 : fc_gather = .false.
1328 : endif
1329 : endif
1330 :
1331 : if (fc_gather) then
1332 :
1333 : #if defined( WRAP_MPI_TIMING )
1334 : call t_startf ('fc_gatherv_char')
1335 : #endif
1336 0 : call mpi_comm_rank (comm, mytid, ier)
1337 0 : call mpi_comm_size (comm, mysize, ier)
1338 0 : mtag = 0
1339 0 : if (root .eq. mytid) then
1340 :
1341 : ! prepost gather_block_size irecvs, and start receiving data
1342 0 : preposts = min(mysize-1, gather_block_size)
1343 0 : head = 0
1344 0 : count = 0
1345 0 : do p=0, mysize-1
1346 0 : if (p .ne. root) then
1347 0 : q = p+1
1348 0 : if (recvcnts(q) > 0) then
1349 0 : count = count + 1
1350 0 : if (count > preposts) then
1351 0 : tail = mod(head,preposts) + 1
1352 0 : call mpi_wait (rcvid(tail), status, ier)
1353 : end if
1354 0 : head = mod(head,preposts) + 1
1355 0 : call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), &
1356 0 : recvtype, p, mtag, comm, rcvid(head), &
1357 0 : ier )
1358 0 : call mpi_send ( signal, 1, mpir8, p, mtag, comm, ier )
1359 : end if
1360 : end if
1361 : end do
1362 :
1363 : ! copy local data
1364 0 : q = mytid+1
1365 0 : do i=1,sendcnt
1366 0 : recvbuf(displs(q)+i) = sendbuf(i)
1367 : enddo
1368 :
1369 : ! wait for final data
1370 0 : do i=1,min(count,preposts)
1371 0 : call mpi_wait (rcvid(i), status, ier)
1372 : enddo
1373 :
1374 : else
1375 :
1376 0 : if (sendcnt > 0) then
1377 : call mpi_recv ( signal, 1, mpir8, root, mtag, comm, &
1378 0 : status, ier )
1379 : call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, &
1380 0 : comm, ier )
1381 : end if
1382 :
1383 : endif
1384 0 : if (ier /= mpi_success) then
1385 0 : write(iulog,*)'fc_gatherv_char failed ier=',ier
1386 0 : call endrun
1387 : end if
1388 : #if defined( WRAP_MPI_TIMING )
1389 : call t_stopf ('fc_gatherv_char')
1390 : #endif
1391 :
1392 : else
1393 :
1394 : #if defined( WRAP_MPI_TIMING )
1395 : call t_startf ('mpi_gatherv')
1396 : #endif
1397 : call mpi_gatherv (sendbuf, sendcnt, sendtype, &
1398 : recvbuf, recvcnts, displs, recvtype, &
1399 1536 : root, comm, ier)
1400 1536 : if (ier /= mpi_success) then
1401 0 : write(iulog,*)'mpi_gatherv failed ier=',ier
1402 0 : call endrun
1403 : end if
1404 : #if defined( WRAP_MPI_TIMING )
1405 : call t_stopf ('mpi_gatherv')
1406 : #endif
1407 :
1408 : endif
1409 :
1410 1536 : return
1411 : end subroutine fc_gathervc
1412 : !
1413 : !========================================================================
1414 : #endif
1415 :
1416 : !-----------------------------------------------------------------------
1417 : !
1418 : ! Purpose: implementations of MPI_Alltoall using different messaging
1419 : ! layers and different communication protocols, controlled
1420 : ! by option argument:
1421 : ! 0: use mpi_alltoallv
1422 : ! 1: use point-to-point MPI-1 two-sided implementation
1423 : ! 2: use point-to-point MPI-2 one-sided implementation if supported,
1424 : ! otherwise use MPI-1 implementation
1425 : ! 3: use Co-Array Fortran implementation if supported,
1426 : ! otherwise use MPI-1 implementation
1427 : ! otherwise use mpi_sendrecv implementation
1428 : !
1429 : ! Entry points:
1430 : ! altalltoallv
1431 : !
1432 : ! Author: P. Worley
1433 : !-----------------------------------------------------------------------
1434 :
1435 : #if (defined SPMD)
1436 : !****************************************************************
1437 0 : subroutine altalltoallv (option, mytid, nprocs, steps, dests, &
1438 0 : sendbuf, sbuf_siz, sendcnts, sdispls, sendtype, &
1439 0 : recvbuf, rbuf_siz, recvcnts, rdispls, recvtype, &
1440 : msgtag, pdispls, desttype, recvwin, comm)
1441 : !
1442 : ! All-to-all scatter/gather implemented using Co-Array
1443 : ! Fortran one-sided commands, MPI-2 one sided commands,
1444 : ! SWAP module MPI-1 commands, MPI_ALLTOALLV or MPI_SENDRECV.
1445 : !
1446 : #if defined( WRAP_MPI_TIMING )
1447 : use perf_mod
1448 : #endif
1449 :
1450 : implicit none
1451 :
1452 : integer, intent(in) :: option ! 0: mpi_alltoallv
1453 : ! 1: swap package
1454 : ! 2: mpi2
1455 : ! 3: co-array fortran
1456 : ! otherwise: sendrecv
1457 : integer, intent(in) :: mytid
1458 : integer, intent(in) :: nprocs
1459 : integer, intent(in) :: steps
1460 : integer, intent(in) :: dests(steps)
1461 : integer, intent(in) :: sbuf_siz
1462 : integer, intent(in) :: sendcnts(0:nprocs-1)
1463 : integer, intent(in) :: sdispls(0:nprocs-1)
1464 : integer, intent(in) :: sendtype
1465 : integer, intent(in) :: rbuf_siz
1466 : integer, intent(in) :: recvcnts(0:nprocs-1)
1467 : integer, intent(in) :: rdispls(0:nprocs-1)
1468 : integer, intent(in) :: recvtype
1469 : integer, intent(in) :: msgtag
1470 : integer, intent(in) :: pdispls(0:nprocs-1) ! displacement at
1471 : ! destination
1472 : integer, intent(in) :: desttype
1473 : integer, intent(in) :: recvwin
1474 : integer, intent(in) :: comm
1475 :
1476 : #if (defined CAF)
1477 : real (r8), intent(in) :: sendbuf(sbuf_siz)[*]
1478 : real (r8), intent(out) :: recvbuf(rbuf_siz)[*]
1479 :
1480 : integer :: istart, iend, jstart, jend
1481 : #else
1482 : real (r8), intent(in) :: sendbuf(sbuf_siz)
1483 : real (r8), intent(out) :: recvbuf(rbuf_siz)
1484 : #endif
1485 :
1486 : integer :: loption ! local copy of option
1487 : integer :: dest ! MPI remote process id
1488 : integer :: ier ! MPI error code
1489 : integer :: i ! loop index
1490 : integer :: sndids(steps) ! nonblocking MPI send request ids
1491 : integer :: rcvids(steps) ! nonblocking MPI recv request ids
1492 : integer :: status(MPI_STATUS_SIZE)
1493 : #if ( defined MPI2)
1494 : integer(kind=MPI_ADDRESS_KIND) :: ddispls
1495 : #endif
1496 :
1497 : !-----------------------------------------------------------------------
1498 0 : loption = option
1499 :
1500 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1501 : ! using MPI library collective MPI_ALLTOALLV
1502 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1503 0 : if (loption .eq. 0) then
1504 :
1505 : #if defined( WRAP_MPI_TIMING )
1506 : call t_startf ('mpi_alltoallv')
1507 : #endif
1508 : call mpi_alltoallv (sendbuf, sendcnts, sdispls, sendtype, &
1509 : recvbuf, recvcnts, rdispls, recvtype, &
1510 0 : comm, ier)
1511 : !
1512 : ! test for error
1513 0 : if (ier/=mpi_success) then
1514 0 : write(iulog,*)'altalltoallv (mpi_alltoallv) failed ier=',ier
1515 0 : call endrun
1516 : end if
1517 : #if defined( WRAP_MPI_TIMING )
1518 : call t_stopf ('mpi_alltoallv')
1519 : #endif
1520 :
1521 : else
1522 :
1523 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1524 : ! Co-Array Fortran implementation of alltoallv
1525 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1526 0 : if (loption .eq. 3) then
1527 :
1528 : #if ( defined CAF )
1529 : #if defined( WRAP_MPI_TIMING )
1530 : call t_startf ('caf_alltoallv')
1531 : #endif
1532 : if (this_image() .ne. (mytid+1)) then
1533 : call endrun('altalltoallv (caf_alltoallv) failed: MPI id .ne. CAF id')
1534 : endif
1535 :
1536 : call sync_images()
1537 :
1538 : do i = 1, steps
1539 : dest = dests(i)
1540 : if (sendcnts(dest) > 0) then
1541 : istart = sdispls(dest)+1
1542 : iend = istart+sendcnts(dest)-1
1543 : jstart = pdispls(dest)+1
1544 : jend = jstart+sendcnts(dest)-1
1545 : recvbuf(jstart:jend)[dest+1] = sendbuf(istart:iend)
1546 : end if
1547 : end do
1548 :
1549 : call sync_images()
1550 : #if defined( WRAP_MPI_TIMING )
1551 : call t_stopf ('caf_alltoallv')
1552 : #endif
1553 : #else
1554 : loption = -1
1555 : #endif
1556 :
1557 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1558 : ! MPI-2 one-sided implementation of alltoallv
1559 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1560 0 : elseif (loption .eq. 2) then
1561 : #ifdef MPI2
1562 : #if defined( WRAP_MPI_TIMING )
1563 : call t_startf ('mpi2_alltoallv')
1564 : #endif
1565 : call mpi_win_fence(0,recvwin,ier)
1566 : do i=1, steps
1567 : dest = dests(i)
1568 : if (sendcnts(dest) > 0) then
1569 : ddispls = pdispls(dest)
1570 : call mpi_put(sendbuf(sdispls(dest)+1), sendcnts(dest), sendtype, &
1571 : dest, ddispls, sendcnts(dest), desttype, &
1572 : recvwin, ier)
1573 : endif
1574 : end do
1575 : !
1576 : ! wait for completion
1577 : call mpi_win_fence(0,recvwin,ier)
1578 : if (ier/=mpi_success) then
1579 : write(iulog,*)'altalltoallv (mpi2_alltoallv) failed ier=',ier
1580 : call endrun
1581 : end if
1582 : #if defined( WRAP_MPI_TIMING )
1583 : call t_stopf ('mpi2_alltoallv')
1584 : #endif
1585 : #else
1586 : loption = -1
1587 : #endif
1588 :
1589 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1590 : ! MPI-1 two-sided implementation of alltoallv
1591 : ! using SWAP routines
1592 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1593 0 : elseif (loption .eq. 1) then
1594 : #if defined( WRAP_MPI_TIMING )
1595 : call t_startf ('swap_alltoallv')
1596 : #endif
1597 :
1598 : call swapm(steps, nprocs, dests, &
1599 : sendbuf, sbuf_siz, sendcnts, sdispls, &
1600 : recvbuf, rbuf_siz, recvcnts, rdispls, &
1601 0 : comm, swap_comm_protocol, swap_comm_maxreq )
1602 : !
1603 : #if defined( WRAP_MPI_TIMING )
1604 : call t_stopf ('swap_alltoallv')
1605 : #endif
1606 :
1607 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1608 : ! Anything else defined to be MPI_SENDRECV implementation
1609 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1610 : else
1611 : !
1612 : loption = -1
1613 : !
1614 : endif
1615 :
1616 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1617 : ! MPI_SENDRECV implementation of alltoallv
1618 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1619 0 : if (loption .eq. -1) then
1620 : #if defined( WRAP_MPI_TIMING )
1621 : call t_startf ('mpi1_alltoallv')
1622 : #endif
1623 0 : do i=1, steps
1624 0 : dest = dests(i)
1625 0 : call mpi_sendrecv (sendbuf(sdispls(dest)+1), sendcnts(dest), &
1626 : sendtype, dest, msgtag, &
1627 0 : recvbuf(rdispls(dest)+1), recvcnts(dest), &
1628 : recvtype, dest, msgtag, &
1629 0 : comm, status, ier)
1630 : end do
1631 : !
1632 : ! test for error
1633 0 : if (ier/=mpi_success) then
1634 0 : write(iulog,*)'altalltoallv (mpi1_alltoallv) failed ier=',ier
1635 0 : call endrun
1636 : end if
1637 :
1638 : #if defined( WRAP_MPI_TIMING )
1639 : call t_stopf ('mpi1_alltoallv')
1640 : #endif
1641 : endif
1642 :
1643 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1644 : ! Local copy (if necessary)
1645 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1646 0 : if (sendcnts(mytid) > 0) then
1647 0 : do i=1,sendcnts(iam)
1648 0 : recvbuf(rdispls(mytid)+i) = sendbuf(sdispls(mytid)+i)
1649 : enddo
1650 : endif
1651 : !
1652 : endif
1653 : !
1654 0 : return
1655 : end subroutine altalltoallv
1656 :
1657 : #endif
1658 :
1659 1536 : subroutine spmd_utils_readnl(nlfile)
1660 : !-----------------------------------------------------------------------
1661 : !
1662 : ! Purpose:
1663 : ! Read spmd utils namelist to set swap communication protocol options as
1664 : ! well as the flow control gather options
1665 : !
1666 : ! Method:
1667 : ! spmd_utils_readnl:
1668 : !
1669 : ! Author of original version: J. Truesdale
1670 : !
1671 : !-----------------------------------------------------------------------
1672 :
1673 : !-----------------------------------------------------------------------
1674 : use namelist_utils, only: find_group_name
1675 : use units, only: getunit, freeunit
1676 : use mpishorthand
1677 :
1678 : implicit none
1679 : !---------------------------Input arguments--------------------------
1680 : !
1681 : character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input
1682 :
1683 : #if ( defined SPMD )
1684 : !---------------------------Local variables--------------------------
1685 : !
1686 : integer :: unitn, ierr
1687 : character(len=*), parameter :: subname = 'spmd_utils_readnl'
1688 :
1689 : namelist /spmd_utils_nl/ swap_comm_protocol,swap_comm_maxreq,fc_gather_flow_cntl
1690 :
1691 : !-----------------------------------------------------------------------------
1692 :
1693 1536 : if (masterproc) then
1694 2 : unitn = getunit()
1695 2 : open( unitn, file=trim(nlfile), status='old' )
1696 2 : call find_group_name(unitn, 'spmd_utils_nl', status=ierr)
1697 2 : if (ierr == 0) then
1698 0 : read(unitn, spmd_utils_nl, iostat=ierr)
1699 0 : if (ierr /= 0) then
1700 0 : call endrun(subname // ':: ERROR reading namelist')
1701 : end if
1702 0 : write(iulog,*) 'Read in spmd_utils_nl namelist from: ', trim(nlfile)
1703 : end if
1704 2 : close(unitn)
1705 2 : call freeunit(unitn)
1706 :
1707 :
1708 2 : if ((swap_comm_protocol < min_comm_protocol) .or. &
1709 : (swap_comm_protocol > max_comm_protocol)) then
1710 : write(iulog,*) &
1711 0 : 'SPMD_UTILS_READNL: ERROR: swap_comm_protocol=', &
1712 0 : swap_comm_protocol, ' is out of range.'
1713 : write(iulog,*) &
1714 0 : ' It must be between ', min_comm_protocol,' and ',&
1715 0 : max_comm_protocol
1716 : write(iulog,*) &
1717 0 : ' Using default value.'
1718 0 : swap_comm_protocol = def_comm_protocol
1719 : endif
1720 :
1721 2 : write(iulog,*) 'SPMD SWAP_COMM OPTIONS: '
1722 2 : write(iulog,*) ' swap_comm_protocol = ', swap_comm_protocol
1723 2 : write(iulog,*) ' swap_comm_maxreq = ', swap_comm_maxreq
1724 2 : write(iulog,*) 'SPMD FLOW CONTROL GATHER OPTION: '
1725 2 : write(iulog,*) ' fc_gather_flow_cntl = ', fc_gather_flow_cntl
1726 : endif
1727 :
1728 : ! Broadcast namelist variables
1729 1536 : call mpibcast (swap_comm_protocol , 1, mpiint , 0, mpicom)
1730 1536 : call mpibcast (swap_comm_maxreq , 1, mpiint , 0, mpicom)
1731 1536 : call mpibcast (fc_gather_flow_cntl, 1, mpiint , 0, mpicom)
1732 : #endif
1733 :
1734 1536 : end subroutine spmd_utils_readnl
1735 :
1736 0 : end module spmd_utils
|
