Oasis3-MCT
 All Classes Files Functions Variables Macros Pages
mod_oasis_mpi.F90
Go to the documentation of this file.
1 !> Provides a generic and simpler interface into MPI calls for OASIS.
2 
4 
5 !-------------------------------------------------------------------------------
6 ! PURPOSE: general layer on MPI functions
7 !-------------------------------------------------------------------------------
8 
10  USE mod_oasis_data ,ONLY: nulprt, oasis_debug
13 
14  implicit none
15  private
16 
17 ! PUBLIC: Public interfaces
18 
19  public :: oasis_mpi_chkerr
20  public :: oasis_mpi_send
21  public :: oasis_mpi_recv
22  public :: oasis_mpi_bcast
23  public :: oasis_mpi_gathscatvinit
24  public :: oasis_mpi_gatherv
25  public :: oasis_mpi_scatterv
26  public :: oasis_mpi_sum
27  public :: oasis_mpi_min
28  public :: oasis_mpi_max
29  public :: oasis_mpi_commsize
30  public :: oasis_mpi_commrank
31  public :: oasis_mpi_initialized
32  public :: oasis_mpi_wtime
33  public :: oasis_mpi_abort
34  public :: oasis_mpi_barrier
35  public :: oasis_mpi_init
36  public :: oasis_mpi_finalize
37  public :: oasis_mpi_reducelists
38 
39  !> Generic overloaded interface into MPI send
40  interface oasis_mpi_send ; module procedure &
46  end interface
47 
48  !> Generic overloaded interface into MPI receive
49  interface oasis_mpi_recv ; module procedure &
55  end interface
56 
57  !> Generic overloaded interface into MPI broadcast
58  interface oasis_mpi_bcast ; module procedure &
70  end interface
71 
72  !> Generic interface to oasis_mpi_gathScatVInit
73  interface oasis_mpi_gathscatvinit ; module procedure &
75  end interface
76 
77  !> Generic interfaces into an MPI vector gather
78  interface oasis_mpi_gatherv ; module procedure &
80  end interface
81 
82  !> Generic interfaces into an MPI vector scatter
83  interface oasis_mpi_scatterv ; module procedure &
85  end interface
86 
87  !> Generic overloaded interface into MPI sum reduction
88  interface oasis_mpi_sum ; module procedure &
97  end interface
98 
99  !> Generic overloaded interface into MPI min reduction
100  interface oasis_mpi_min ; module procedure &
101  oasis_mpi_mini0, &
102  oasis_mpi_mini1, &
103  oasis_mpi_minr0, &
105  end interface
106 
107  !> Generic overloaded interface into MPI max reduction
108  interface oasis_mpi_max ; module procedure &
109  oasis_mpi_maxi0, &
110  oasis_mpi_maxi1, &
111  oasis_mpi_maxr0, &
113  end interface
114 
115 ! mpi library include file
116 #include <mpif.h>
117 
118 !===============================================================================
119 CONTAINS
120 !===============================================================================
121 
122 !> Checks MPI error codes and aborts
123 
124 !> This method compares rcode to MPI_SUCCESS. If rcode is an error,
125 !> it queries MPI_ERROR_STRING for the error string associated with rcode, writes
126 !> it out, and aborts with the string passed through the interface.
127 
128 SUBROUTINE oasis_mpi_chkerr(rcode,string)
129 
130  IMPLICIT none
131 
132  !----- arguments ---
133  integer(ip_i4_p), intent(in) :: rcode !< MPI error code
134  character(*), intent(in) :: string !< abort message
135 
136  !----- local ---
137  character(*),parameter :: subname = '(oasis_mpi_chkerr)'
138  character(MPI_MAX_ERROR_STRING) :: lstring
139  integer(ip_i4_p) :: len
140  integer(ip_i4_p) :: ierr
141 
142 !-------------------------------------------------------------------------------
143 ! PURPOSE: layer on MPI error checking
144 !-------------------------------------------------------------------------------
145 
146  call oasis_debug_enter(subname)
147 
148  lstring = ' '
149  if (rcode /= mpi_success) then
150  call mpi_error_string(rcode,lstring,len,ierr)
151  call oasis_mpi_abort(subname//trim(string)//':'//trim(lstring),rcode)
152  endif
153 
154  call oasis_debug_exit(subname)
155 
156 END SUBROUTINE oasis_mpi_chkerr
157 
158 !===============================================================================
159 !===============================================================================
160 
161 !> Send a scalar integer
162 
163 SUBROUTINE oasis_mpi_sendi0(lvec,pid,tag,comm,string)
164 
165  IMPLICIT none
166 
167  !----- arguments ---
168  integer(ip_i4_p), intent(in) :: lvec !< send value
169  integer(ip_i4_p), intent(in) :: pid !< pid to send to
170  integer(ip_i4_p), intent(in) :: tag !< tag
171  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
172  character(*),optional,intent(in) :: string !< to identify caller
173 
174  !----- local ---
175  character(*),parameter :: subname = '(oasis_mpi_sendi0)'
176  integer(ip_i4_p) :: lsize
177  integer(ip_i4_p) :: ierr
178 
179 !-------------------------------------------------------------------------------
180 ! PURPOSE: Send a single integer
181 !-------------------------------------------------------------------------------
182 
183  call oasis_debug_enter(subname)
184 
185  lsize = 1
186 
187  call mpi_send(lvec,lsize,mpi_integer,pid,tag,comm,ierr)
188  if (present(string)) then
189  call oasis_mpi_chkerr(ierr,subname//trim(string))
190  else
191  call oasis_mpi_chkerr(ierr,subname)
192  endif
193 
194  call oasis_debug_exit(subname)
195 
196 END SUBROUTINE oasis_mpi_sendi0
197 
198 !===============================================================================
199 !===============================================================================
200 
201 !> Send an array of 1D integers
202 
203 SUBROUTINE oasis_mpi_sendi1(lvec,pid,tag,comm,string)
204 
205  IMPLICIT none
206 
207  !----- arguments ---
208  integer(ip_i4_p), intent(in) :: lvec(:) !< send values
209  integer(ip_i4_p), intent(in) :: pid !< pid to send to
210  integer(ip_i4_p), intent(in) :: tag !< tag
211  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
212  character(*),optional,intent(in) :: string !< to identify caller
213 
214  !----- local ---
215  character(*),parameter :: subname = '(oasis_mpi_sendi1)'
216  integer(ip_i4_p) :: lsize
217  integer(ip_i4_p) :: ierr
218 
219 !-------------------------------------------------------------------------------
220 ! PURPOSE: Send a vector of integers
221 !-------------------------------------------------------------------------------
222 
223  call oasis_debug_enter(subname)
224 
225  lsize = size(lvec)
226 
227  call mpi_send(lvec,lsize,mpi_integer,pid,tag,comm,ierr)
228  if (present(string)) then
229  call oasis_mpi_chkerr(ierr,subname//trim(string))
230  else
231  call oasis_mpi_chkerr(ierr,subname)
232  endif
233 
234  call oasis_debug_exit(subname)
235 
236 END SUBROUTINE oasis_mpi_sendi1
237 
238 !===============================================================================
239 !===============================================================================
240 
241 !> Send a scalar double
242 
243 SUBROUTINE oasis_mpi_sendr0(lvec,pid,tag,comm,string)
244 
245  IMPLICIT none
246 
247  !----- arguments ---
248  real(ip_double_p),intent(in) :: lvec !< send values
249  integer(ip_i4_p), intent(in) :: pid !< pid to send to
250  integer(ip_i4_p), intent(in) :: tag !< tag
251  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
252  character(*),optional,intent(in) :: string !< to identify caller
253 
254  !----- local ---
255  character(*),parameter :: subname = '(oasis_mpi_sendr0)'
256  integer(ip_i4_p) :: lsize
257  integer(ip_i4_p) :: ierr
258 
259 !-------------------------------------------------------------------------------
260 ! PURPOSE: Send a real scalar
261 !-------------------------------------------------------------------------------
262 
263  call oasis_debug_enter(subname)
264 
265  lsize = 1
266 
267  call mpi_send(lvec,lsize,mpi_real8,pid,tag,comm,ierr)
268  if (present(string)) then
269  call oasis_mpi_chkerr(ierr,subname//trim(string))
270  else
271  call oasis_mpi_chkerr(ierr,subname)
272  endif
273 
274  call oasis_debug_exit(subname)
275 
276 END SUBROUTINE oasis_mpi_sendr0
277 
278 !===============================================================================
279 !===============================================================================
280 
281 !> Send an array of 1D doubles
282 
283 SUBROUTINE oasis_mpi_sendr1(lvec,pid,tag,comm,string)
284 
285  IMPLICIT none
286 
287  !----- arguments ---
288  real(ip_double_p),intent(in) :: lvec(:) !< send values
289  integer(ip_i4_p), intent(in) :: pid !< pid to send to
290  integer(ip_i4_p), intent(in) :: tag !< tag
291  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
292  character(*),optional,intent(in) :: string !< to identify caller
293 
294  !----- local ---
295  character(*),parameter :: subname = '(oasis_mpi_sendr1)'
296  integer(ip_i4_p) :: lsize
297  integer(ip_i4_p) :: ierr
298 
299 !-------------------------------------------------------------------------------
300 ! PURPOSE: Send a vector of reals
301 !-------------------------------------------------------------------------------
302 
303  call oasis_debug_enter(subname)
304 
305  lsize = size(lvec)
306 
307  call mpi_send(lvec,lsize,mpi_real8,pid,tag,comm,ierr)
308  if (present(string)) then
309  call oasis_mpi_chkerr(ierr,subname//trim(string))
310  else
311  call oasis_mpi_chkerr(ierr,subname)
312  endif
313 
314  call oasis_debug_exit(subname)
315 
316 END SUBROUTINE oasis_mpi_sendr1
317 
318 !===============================================================================
319 !===============================================================================
320 
321 !> Send an array of 3D doubles
322 
323 SUBROUTINE oasis_mpi_sendr3(array,pid,tag,comm,string)
324 
325  IMPLICIT none
326 
327  !----- arguments ---
328  real(ip_double_p),intent(in) :: array(:,:,:) !< send values
329  integer(ip_i4_p), intent(in) :: pid !< pid to send to
330  integer(ip_i4_p), intent(in) :: tag !< tag
331  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
332  character(*),optional,intent(in) :: string !< to identify caller
333 
334  !----- local ---
335  character(*),parameter :: subname = '(oasis_mpi_sendr3)'
336  integer(ip_i4_p) :: lsize
337  integer(ip_i4_p) :: ierr
338 
339 !-------------------------------------------------------------------------------
340 ! PURPOSE: Send a vector of reals
341 !-------------------------------------------------------------------------------
342 
343  call oasis_debug_enter(subname)
344 
345  lsize = size(array)
346 
347  call mpi_send(array,lsize,mpi_real8,pid,tag,comm,ierr)
348  if (present(string)) then
349  call oasis_mpi_chkerr(ierr,subname//trim(string))
350  else
351  call oasis_mpi_chkerr(ierr,subname)
352  endif
353 
354  call oasis_debug_exit(subname)
355 
356 END SUBROUTINE oasis_mpi_sendr3
357 
358 !===============================================================================
359 !===============================================================================
360 
361 !> Receive a scalar integer
362 
363 SUBROUTINE oasis_mpi_recvi0(lvec,pid,tag,comm,string)
364 
365  IMPLICIT none
366 
367  !----- arguments ---
368  integer(ip_i4_p), intent(out):: lvec !< receive values
369  integer(ip_i4_p), intent(in) :: pid !< pid to recv from
370  integer(ip_i4_p), intent(in) :: tag !< tag
371  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
372  character(*),optional,intent(in) :: string !< to identify caller
373 
374  !----- local ---
375  character(*),parameter :: subname = '(oasis_mpi_recvi0)'
376  integer(ip_i4_p) :: lsize
377  integer(ip_i4_p) :: status(mpi_status_size) ! mpi status info
378  integer(ip_i4_p) :: ierr
379 
380 !-------------------------------------------------------------------------------
381 ! PURPOSE: Recv a vector of reals
382 !-------------------------------------------------------------------------------
383 
384  call oasis_debug_enter(subname)
385 
386  lsize = 1
387 
388  call mpi_recv(lvec,lsize,mpi_integer,pid,tag,comm,status,ierr)
389  if (present(string)) then
390  call oasis_mpi_chkerr(ierr,subname//trim(string))
391  else
392  call oasis_mpi_chkerr(ierr,subname)
393  endif
394 
395  call oasis_debug_exit(subname)
396 
397 END SUBROUTINE oasis_mpi_recvi0
398 
399 !===============================================================================
400 !===============================================================================
401 
402 !> Receive an array of 1D integers
403 
404 SUBROUTINE oasis_mpi_recvi1(lvec,pid,tag,comm,string)
405 
406  IMPLICIT none
407 
408  !----- arguments ---
409  integer(ip_i4_p), intent(out):: lvec(:) !< receive values
410  integer(ip_i4_p), intent(in) :: pid !< pid to recv from
411  integer(ip_i4_p), intent(in) :: tag !< tag
412  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
413  character(*),optional,intent(in) :: string !< to identify caller
414 
415  !----- local ---
416  character(*),parameter :: subname = '(oasis_mpi_recvi1)'
417  integer(ip_i4_p) :: lsize
418  integer(ip_i4_p) :: status(mpi_status_size) ! mpi status info
419  integer(ip_i4_p) :: ierr
420 
421 !-------------------------------------------------------------------------------
422 ! PURPOSE: Recv a vector of reals
423 !-------------------------------------------------------------------------------
424 
425  call oasis_debug_enter(subname)
426 
427  lsize = size(lvec)
428 
429  call mpi_recv(lvec,lsize,mpi_integer,pid,tag,comm,status,ierr)
430  if (present(string)) then
431  call oasis_mpi_chkerr(ierr,subname//trim(string))
432  else
433  call oasis_mpi_chkerr(ierr,subname)
434  endif
435 
436  call oasis_debug_exit(subname)
437 
438 END SUBROUTINE oasis_mpi_recvi1
439 
440 !===============================================================================
441 !===============================================================================
442 
443 !> Receive a scalar double
444 
445 SUBROUTINE oasis_mpi_recvr0(lvec,pid,tag,comm,string)
446 
447  IMPLICIT none
448 
449  !----- arguments ---
450  real(ip_double_p),intent(out):: lvec !< receive values
451  integer(ip_i4_p), intent(in) :: pid !< pid to recv from
452  integer(ip_i4_p), intent(in) :: tag !< tag
453  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
454  character(*),optional,intent(in) :: string !< to identify caller
455 
456  !----- local ---
457  character(*),parameter :: subname = '(oasis_mpi_recvr0)'
458  integer(ip_i4_p) :: lsize
459  integer(ip_i4_p) :: status(mpi_status_size) ! mpi status info
460  integer(ip_i4_p) :: ierr
461 
462 !-------------------------------------------------------------------------------
463 ! PURPOSE: Recv a vector of reals
464 !-------------------------------------------------------------------------------
465 
466  call oasis_debug_enter(subname)
467 
468  lsize = 1
469 
470  call mpi_recv(lvec,lsize,mpi_real8,pid,tag,comm,status,ierr)
471  if (present(string)) then
472  call oasis_mpi_chkerr(ierr,subname//trim(string))
473  else
474  call oasis_mpi_chkerr(ierr,subname)
475  endif
476 
477  call oasis_debug_exit(subname)
478 
479 END SUBROUTINE oasis_mpi_recvr0
480 
481 !===============================================================================
482 !===============================================================================
483 
484 !> Receive an array of 1D doubles
485 
486 SUBROUTINE oasis_mpi_recvr1(lvec,pid,tag,comm,string)
487 
488  IMPLICIT none
489 
490  !----- arguments ---
491  real(ip_double_p),intent(out):: lvec(:) !< receive values
492  integer(ip_i4_p), intent(in) :: pid !< pid to recv from
493  integer(ip_i4_p), intent(in) :: tag !< tag
494  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
495  character(*),optional,intent(in) :: string !< to identify caller
496 
497  !----- local ---
498  character(*),parameter :: subname = '(oasis_mpi_recvr1)'
499  integer(ip_i4_p) :: lsize
500  integer(ip_i4_p) :: status(mpi_status_size) ! mpi status info
501  integer(ip_i4_p) :: ierr
502 
503 !-------------------------------------------------------------------------------
504 ! PURPOSE: Recv a vector of reals
505 !-------------------------------------------------------------------------------
506 
507  call oasis_debug_enter(subname)
508 
509  lsize = size(lvec)
510 
511  call mpi_recv(lvec,lsize,mpi_real8,pid,tag,comm,status,ierr)
512  if (present(string)) then
513  call oasis_mpi_chkerr(ierr,subname//trim(string))
514  else
515  call oasis_mpi_chkerr(ierr,subname)
516  endif
517 
518  call oasis_debug_exit(subname)
519 
520 END SUBROUTINE oasis_mpi_recvr1
521 
522 !===============================================================================
523 !===============================================================================
524 
525 !> Receive an array of 3D doubles
526 
527 SUBROUTINE oasis_mpi_recvr3(array,pid,tag,comm,string)
528 
529  IMPLICIT none
530 
531  !----- arguments ---
532  real(ip_double_p),intent(out):: array(:,:,:) !< receive values
533  integer(ip_i4_p), intent(in) :: pid !< pid to recv from
534  integer(ip_i4_p), intent(in) :: tag !< tag
535  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
536  character(*),optional,intent(in) :: string !< to identify caller
537 
538  !----- local ---
539  character(*),parameter :: subname = '(oasis_mpi_recvr3)'
540  integer(ip_i4_p) :: lsize
541  integer(ip_i4_p) :: status(mpi_status_size) ! mpi status info
542  integer(ip_i4_p) :: ierr
543 
544 !-------------------------------------------------------------------------------
545 ! PURPOSE: Recv a vector of reals
546 !-------------------------------------------------------------------------------
547 
548  call oasis_debug_enter(subname)
549 
550  lsize = size(array)
551 
552  call mpi_recv(array,lsize,mpi_real8,pid,tag,comm,status,ierr)
553  if (present(string)) then
554  call oasis_mpi_chkerr(ierr,subname//trim(string))
555  else
556  call oasis_mpi_chkerr(ierr,subname)
557  endif
558 
559  call oasis_debug_exit(subname)
560 
561 END SUBROUTINE oasis_mpi_recvr3
562 
563 !===============================================================================
564 !===============================================================================
565 
566 !> Broadcast a scalar integer
567 
568 SUBROUTINE oasis_mpi_bcasti0(vec,comm,string,pebcast)
569 
570  IMPLICIT none
571 
572  !----- arguments ---
573  integer(ip_i4_p), intent(inout):: vec !< values to broadcast
574  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
575  character(*),optional,intent(in) :: string !< to identify caller
576  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
577 
578  !----- local ---
579  character(*),parameter :: subname = '(oasis_mpi_bcasti0)'
580  integer(ip_i4_p) :: ierr
581  integer(ip_i4_p) :: lsize
582  integer(ip_i4_p) :: lpebcast
583 
584 !-------------------------------------------------------------------------------
585 ! PURPOSE: Broadcast an integer
586 !-------------------------------------------------------------------------------
587 
588  call oasis_debug_enter(subname)
589 
590  lsize = 1
591  lpebcast = 0
592  if (present(pebcast)) lpebcast = pebcast
593 
594  call mpi_bcast(vec,lsize,mpi_integer,lpebcast,comm,ierr)
595  if (present(string)) then
596  call oasis_mpi_chkerr(ierr,subname//trim(string))
597  else
598  call oasis_mpi_chkerr(ierr,subname)
599  endif
600 
601  call oasis_debug_exit(subname)
602 
603 END SUBROUTINE oasis_mpi_bcasti0
604 
605 !===============================================================================
606 !===============================================================================
607 
608 !> Broadcast a scalar logical
609 
610 SUBROUTINE oasis_mpi_bcastl0(vec,comm,string,pebcast)
611 
612  IMPLICIT none
613 
614  !----- arguments ---
615  logical, intent(inout):: vec !< values to broadcast
616  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
617  character(*),optional,intent(in) :: string !< to identify caller
618  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
619 
620  !----- local ---
621  character(*),parameter :: subname = '(oasis_mpi_bcastl0)'
622  integer(ip_i4_p) :: ierr
623  integer(ip_i4_p) :: lsize
624  integer(ip_i4_p) :: lpebcast
625 
626 !-------------------------------------------------------------------------------
627 ! PURPOSE: Broadcast a logical
628 !-------------------------------------------------------------------------------
629 
630  call oasis_debug_enter(subname)
631 
632  lsize = 1
633  lpebcast = 0
634  if (present(pebcast)) lpebcast = pebcast
635 
636  call mpi_bcast(vec,lsize,mpi_logical,lpebcast,comm,ierr)
637  if (present(string)) then
638  call oasis_mpi_chkerr(ierr,subname//trim(string))
639  else
640  call oasis_mpi_chkerr(ierr,subname)
641  endif
642 
643  call oasis_debug_exit(subname)
644 
645 END SUBROUTINE oasis_mpi_bcastl0
646 
647 !===============================================================================
648 !===============================================================================
649 
650 !> Broadcast a character string
651 
652 SUBROUTINE oasis_mpi_bcastc0(vec,comm,string,pebcast)
653 
654  IMPLICIT none
655 
656  !----- arguments ---
657  character(len=*), intent(inout):: vec !< values to broadcast
658  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
659  character(*),optional,intent(in) :: string !< to identify caller
660  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
661 
662  !----- local ---
663  character(*),parameter :: subname = '(oasis_mpi_bcastc0)'
664  integer(ip_i4_p) :: ierr
665  integer(ip_i4_p) :: lsize
666  integer(ip_i4_p) :: lpebcast
667 
668 !-------------------------------------------------------------------------------
669 ! PURPOSE: Broadcast a character string
670 !-------------------------------------------------------------------------------
671 
672  call oasis_debug_enter(subname)
673 
674  lsize = len(vec)
675  lpebcast = 0
676  if (present(pebcast)) lpebcast = pebcast
677 
678  call mpi_bcast(vec,lsize,mpi_character,lpebcast,comm,ierr)
679  if (present(string)) then
680  call oasis_mpi_chkerr(ierr,subname//trim(string))
681  else
682  call oasis_mpi_chkerr(ierr,subname)
683  endif
684 
685  call oasis_debug_exit(subname)
686 
687 END SUBROUTINE oasis_mpi_bcastc0
688 
689 !===============================================================================
690 !===============================================================================
691 
692 !> Broadcast an array of 1D character strings
693 
694 SUBROUTINE oasis_mpi_bcastc1(vec,comm,string,pebcast)
695 
696  IMPLICIT none
697 
698  !----- arguments ---
699  character(len=*), intent(inout):: vec(:) !< values to broadcast
700  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
701  character(*),optional,intent(in) :: string !< to identify caller
702  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
703 
704  !----- local ---
705  character(*),parameter :: subname = '(oasis_mpi_bcastc1)'
706  integer(ip_i4_p) :: ierr
707  integer(ip_i4_p) :: lsize
708  integer(ip_i4_p) :: lpebcast
709 
710 !-------------------------------------------------------------------------------
711 ! PURPOSE: Broadcast a character string
712 !-------------------------------------------------------------------------------
713 
714  call oasis_debug_enter(subname)
715 
716  lsize = size(vec)*len(vec)
717  lpebcast = 0
718  if (present(pebcast)) lpebcast = pebcast
719 
720  call mpi_bcast(vec,lsize,mpi_character,lpebcast,comm,ierr)
721  if (present(string)) then
722  call oasis_mpi_chkerr(ierr,subname//trim(string))
723  else
724  call oasis_mpi_chkerr(ierr,subname)
725  endif
726 
727  call oasis_debug_exit(subname)
728 
729 END SUBROUTINE oasis_mpi_bcastc1
730 
731 !===============================================================================
732 !===============================================================================
733 
734 !> Broadcast a scalar double
735 
736 SUBROUTINE oasis_mpi_bcastr0(vec,comm,string,pebcast)
737 
738  IMPLICIT none
739 
740  !----- arguments ---
741  real(ip_double_p), intent(inout):: vec !< values to broadcast
742  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
743  character(*),optional,intent(in) :: string !< to identify caller
744  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
745 
746  !----- local ---
747  character(*),parameter :: subname = '(oasis_mpi_bcastr0)'
748  integer(ip_i4_p) :: ierr
749  integer(ip_i4_p) :: lsize
750  integer(ip_i4_p) :: lpebcast
751 
752 !-------------------------------------------------------------------------------
753 ! PURPOSE: Broadcast a real
754 !-------------------------------------------------------------------------------
755 
756  call oasis_debug_enter(subname)
757 
758  lsize = 1
759  lpebcast = 0
760  if (present(pebcast)) lpebcast = pebcast
761 
762  call mpi_bcast(vec,lsize,mpi_real8,lpebcast,comm,ierr)
763  if (present(string)) then
764  call oasis_mpi_chkerr(ierr,subname//trim(string))
765  else
766  call oasis_mpi_chkerr(ierr,subname)
767  endif
768 
769  call oasis_debug_exit(subname)
770 
771 END SUBROUTINE oasis_mpi_bcastr0
772 
773 !===============================================================================
774 !===============================================================================
775 
776 !> Broadcast an array of 1D integers
777 
778 SUBROUTINE oasis_mpi_bcasti1(vec,comm,string,pebcast)
779 
780  IMPLICIT none
781 
782  !----- arguments ---
783  integer(ip_i4_p), intent(inout):: vec(:) !< values to broadcast
784  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
785  character(*),optional,intent(in) :: string !< to identify caller
786  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
787 
788  !----- local ---
789  character(*),parameter :: subname = '(oasis_mpi_bcasti1)'
790  integer(ip_i4_p) :: ierr
791  integer(ip_i4_p) :: lsize
792  integer(ip_i4_p) :: lpebcast
793 
794 !-------------------------------------------------------------------------------
795 ! PURPOSE: Broadcast a vector of integers
796 !-------------------------------------------------------------------------------
797 
798  call oasis_debug_enter(subname)
799 
800  lsize = size(vec)
801  lpebcast = 0
802  if (present(pebcast)) lpebcast = pebcast
803 
804  call mpi_bcast(vec,lsize,mpi_integer,lpebcast,comm,ierr)
805  if (present(string)) then
806  call oasis_mpi_chkerr(ierr,subname//trim(string))
807  else
808  call oasis_mpi_chkerr(ierr,subname)
809  endif
810 
811  call oasis_debug_exit(subname)
812 
813 END SUBROUTINE oasis_mpi_bcasti1
814 
815 !===============================================================================
816 !===============================================================================
817 
818 !> Broadcast an array of 1D logicals
819 
820 SUBROUTINE oasis_mpi_bcastl1(vec,comm,string,pebcast)
821 
822  IMPLICIT none
823 
824  !----- arguments ---
825  logical, intent(inout):: vec(:) !< values to broadcast
826  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
827  character(*),optional,intent(in) :: string !< to identify caller
828  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
829 
830  !----- local ---
831  character(*),parameter :: subname = '(oasis_mpi_bcastl1)'
832  integer(ip_i4_p) :: ierr
833  integer(ip_i4_p) :: lsize
834  integer(ip_i4_p) :: lpebcast
835 
836 !-------------------------------------------------------------------------------
837 ! PURPOSE: Broadcast a logical
838 !-------------------------------------------------------------------------------
839 
840  call oasis_debug_enter(subname)
841 
842  lsize = size(vec)
843  lpebcast = 0
844  if (present(pebcast)) lpebcast = pebcast
845 
846  call mpi_bcast(vec,lsize,mpi_logical,lpebcast,comm,ierr)
847  if (present(string)) then
848  call oasis_mpi_chkerr(ierr,subname//trim(string))
849  else
850  call oasis_mpi_chkerr(ierr,subname)
851  endif
852 
853  call oasis_debug_exit(subname)
854 
855 END SUBROUTINE oasis_mpi_bcastl1
856 
857 !===============================================================================
858 !===============================================================================
859 
860 !> Broadcast an array of 1D doubles
861 
862 SUBROUTINE oasis_mpi_bcastr1(vec,comm,string,pebcast)
863 
864  IMPLICIT none
865 
866  !----- arguments ---
867  real(ip_double_p), intent(inout):: vec(:) !< values to broadcast
868  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
869  character(*),optional,intent(in) :: string !< to identify caller
870  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
871 
872  !----- local ---
873  character(*),parameter :: subname = '(oasis_mpi_bcastr1)'
874  integer(ip_i4_p) :: ierr
875  integer(ip_i4_p) :: lsize
876  integer(ip_i4_p) :: lpebcast
877 
878 !-------------------------------------------------------------------------------
879 ! PURPOSE: Broadcast a vector of reals
880 !-------------------------------------------------------------------------------
881 
882  call oasis_debug_enter(subname)
883 
884  lsize = size(vec)
885  lpebcast = 0
886  if (present(pebcast)) lpebcast = pebcast
887 
888  call mpi_bcast(vec,lsize,mpi_real8,lpebcast,comm,ierr)
889  if (present(string)) then
890  call oasis_mpi_chkerr(ierr,subname//trim(string))
891  else
892  call oasis_mpi_chkerr(ierr,subname)
893  endif
894 
895  call oasis_debug_exit(subname)
896 
897 END SUBROUTINE oasis_mpi_bcastr1
898 
899 !===============================================================================
900 !===============================================================================
901 
902 !> Broadcast an array of 2D doubles
903 
904 SUBROUTINE oasis_mpi_bcastr2(arr,comm,string,pebcast)
905 
906  IMPLICIT none
907 
908  !----- arguments -----
909  real(ip_double_p), intent(inout):: arr(:,:) !< values to broadcast
910  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
911  character(*),optional,intent(in) :: string !< to identify caller
912  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
913 
914  !----- local -----
915  integer(ip_i4_p) :: ierr
916  integer(ip_i4_p) :: lsize
917  integer(ip_i4_p) :: lpebcast
918 
919  !----- formats -----
920  character(*),parameter :: subname = '(oasis_mpi_bcastr2)'
921 
922 !-------------------------------------------------------------------------------
923 ! PURPOSE: Broadcast a 2d array of reals
924 !-------------------------------------------------------------------------------
925 
926  call oasis_debug_enter(subname)
927 
928  lsize = size(arr)
929  lpebcast = 0
930  if (present(pebcast)) lpebcast = pebcast
931 
932  call mpi_bcast(arr,lsize,mpi_real8,lpebcast,comm,ierr)
933  if (present(string)) then
934  call oasis_mpi_chkerr(ierr,subname//trim(string))
935  else
936  call oasis_mpi_chkerr(ierr,subname)
937  endif
938 
939  call oasis_debug_exit(subname)
940 
941 END SUBROUTINE oasis_mpi_bcastr2
942 
943 !===============================================================================
944 !===============================================================================
945 
946 !> Broadcast an array of 2D integers
947 
948 SUBROUTINE oasis_mpi_bcasti2(arr,comm,string,pebcast)
949 
950  IMPLICIT none
951 
952  !----- arguments -----
953  integer, intent(inout):: arr(:,:) !< values to broadcast
954  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
955  character(*),optional,intent(in) :: string !< to identify caller
956  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
957 
958  !----- local -----
959  integer(ip_i4_p) :: ierr
960  integer(ip_i4_p) :: lsize
961  integer(ip_i4_p) :: lpebcast
962 
963  !----- formats -----
964  character(*),parameter :: subname = '(oasis_mpi_bcasti2)'
965 
966 !-------------------------------------------------------------------------------
967 ! PURPOSE: Broadcast a 2d array of integers
968 !-------------------------------------------------------------------------------
969 
970  call oasis_debug_enter(subname)
971 
972  lsize = size(arr)
973  lpebcast = 0
974  if (present(pebcast)) lpebcast = pebcast
975 
976  call mpi_bcast(arr,lsize,mpi_integer,lpebcast,comm,ierr)
977  if (present(string)) then
978  call oasis_mpi_chkerr(ierr,subname//trim(string))
979  else
980  call oasis_mpi_chkerr(ierr,subname)
981  endif
982 
983  call oasis_debug_exit(subname)
984 
985 END SUBROUTINE oasis_mpi_bcasti2
986 
987 !===============================================================================
988 !===============================================================================
989 
990 !> Broadcast an array of 3D doubles
991 
992 SUBROUTINE oasis_mpi_bcastr3(arr,comm,string,pebcast)
993 
994  IMPLICIT none
995 
996  !----- arguments -----
997  real(ip_double_p), intent(inout):: arr(:,:,:) !< values to broadcast
998  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
999  character(*),optional,intent(in) :: string !< to identify caller
1000  integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
1001 
1002  !----- local -----
1003  integer(ip_i4_p) :: ierr
1004  integer(ip_i4_p) :: lsize
1005  integer(ip_i4_p) :: lpebcast
1006 
1007  !----- formats -----
1008  character(*),parameter :: subname = '(oasis_mpi_bcastr3)'
1009 
1010 !-------------------------------------------------------------------------------
1011 ! PURPOSE: Broadcast a 3d array of reals
1012 !-------------------------------------------------------------------------------
1013 
1014  call oasis_debug_enter(subname)
1015 
1016  lsize = size(arr)
1017  lpebcast = 0
1018  if (present(pebcast)) lpebcast = pebcast
1019 
1020  call mpi_bcast(arr,lsize,mpi_real8,lpebcast,comm,ierr)
1021  if (present(string)) then
1022  call oasis_mpi_chkerr(ierr,subname//trim(string))
1023  else
1024  call oasis_mpi_chkerr(ierr,subname)
1025  endif
1026 
1027  call oasis_debug_exit(subname)
1028 
1029 END SUBROUTINE oasis_mpi_bcastr3
1030 
1031 !===============================================================================
1032 !===============================================================================
1033 
1034 !> Initialize variables for oasis_mpi_gatherv and oasis_mpi_scatterv
1035 
1036 !> This method initializes glob1DArr, globSize, and displs for use
1037 !> in the oasis_mpi_gatherv and oasis_mpi_scatterv routines. locArr is the
1038 !> distributed array to gather from or scatter to.
1039 
1040 SUBROUTINE oasis_mpi_gathscatvinitr1(comm, rootid, locArr, glob1DArr, globSize, &
1041  displs, string )
1042 
1043  IMPLICIT none
1044 
1045  !----- arguments -----
1046  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1047  integer(ip_i4_p), intent(in) :: rootid !< MPI task to gather/scatter on
1048  real(ip_double_p),intent(in) :: locArr(:) !< Local array of distributed data
1049  real(ip_double_p),pointer :: glob1DArr(:) !< Global 1D array of gathered data
1050  integer(ip_i4_p), pointer :: globSize(:) !< Size of each distributed piece
1051  integer(ip_i4_p), pointer :: displs(:) !< Displacements for receive
1052  character(*),optional,intent(in):: string !< to identify caller
1053 
1054  !----- local -----
1055  integer(ip_i4_p) :: npes ! Number of MPI tasks
1056  integer(ip_i4_p) :: locSize ! Size of local distributed data
1057  integer(ip_i4_p), pointer :: sendSize(:) ! Size to send for initial gather
1058  integer(ip_i4_p) :: i ! Index
1059  integer(ip_i4_p) :: rank ! Rank of this MPI task
1060  integer(ip_i4_p) :: nSize ! Maximum size to send
1061  integer(ip_i4_p) :: ierr ! Error code
1062  integer(ip_i4_p) :: nSiz1D ! Size of 1D global array
1063  integer(ip_i4_p) :: maxSize ! Maximum size
1064 
1065  !----- formats -----
1066  character(*),parameter :: subname = '(oasis_mpi_gathScatvInitr1)'
1067 
1068 !-------------------------------------------------------------------------------
1069 ! PURPOSE: Setup arrays for a gatherv/scatterv operation
1070 !-------------------------------------------------------------------------------
1071 
1072  call oasis_debug_enter(subname)
1073 
1074  locsize = size(locarr)
1075  call oasis_mpi_commsize( comm, npes )
1076  call oasis_mpi_commrank( comm, rank )
1077  allocate( globsize(npes) )
1078  !
1079  ! --- Gather the send global sizes from each MPI task -----------------------
1080  !
1081  allocate( sendsize(npes) )
1082  sendsize(:) = 1
1083  globsize(:) = 1
1084  call mpi_gather( locsize, 1, mpi_integer, globsize, sendsize, &
1085  mpi_integer, rootid, comm, ierr )
1086  if (present(string)) then
1087  call oasis_mpi_chkerr(ierr,subname//trim(string))
1088  else
1089  call oasis_mpi_chkerr(ierr,subname)
1090  endif
1091  deallocate( sendsize )
1092  !
1093  ! --- Prepare the displacement and allocate arrays -------------------------
1094  !
1095  allocate( displs(npes) )
1096  displs(1) = 0
1097  if ( rootid /= rank )then
1098  maxsize = 1
1099  globsize = 1
1100  else
1101  maxsize = maxval(globsize)
1102  end if
1103  nsiz1d = min(maxsize,globsize(1))
1104  do i = 2, npes
1105  nsize = min(maxsize,globsize(i-1))
1106  displs(i) = displs(i-1) + nsize
1107  nsiz1d = nsiz1d + min(maxsize,globsize(i))
1108  end do
1109  allocate( glob1darr(nsiz1d) )
1110  !----- Do some error checking for the root task arrays computed ----
1111  if ( rootid == rank )then
1112  if ( nsiz1d /= sum(globsize) ) &
1113  call oasis_mpi_abort( subname//" : Error, size of global array not right" )
1114  if ( any(displs < 0) .or. any(displs >= nsiz1d) ) &
1115  call oasis_mpi_abort( subname//" : Error, displacement array not right" )
1116  if ( (displs(npes)+globsize(npes)) /= nsiz1d ) &
1117  call oasis_mpi_abort( subname//" : Error, displacement array values too big" )
1118  end if
1119 
1120  call oasis_debug_exit(subname)
1121 
1122 END SUBROUTINE oasis_mpi_gathscatvinitr1
1123 
1124 !===============================================================================
1125 !===============================================================================
1126 
1127 !> Gather a vector of distributed data to a rootid
1128 
1129 !> This method passes in glob1DArr, globSize, and displs computed
1130 !> in the oasis_mpi_gathscatvinit routine and uses that information to
1131 !> gather the locArr into the glob1Darr on processor rootid in communicator
1132 !> comm.
1133 
1134 SUBROUTINE oasis_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, &
1135  comm, string )
1136 
1137  IMPLICIT none
1138 
1139  !----- arguments -----
1140  real(ip_double_p),intent(in) :: locArr(:) !< Local array
1141  real(ip_double_p),intent(inout) :: glob1DArr(:) !< Global 1D array to receive in on
1142  integer(ip_i4_p), intent(in) :: locSize !< Number to send from this PE
1143  integer(ip_i4_p), intent(in) :: globSize(:) !< Number to receive from each PE
1144  integer(ip_i4_p), intent(in) :: displs(:) !< Displacements for receives
1145  integer(ip_i4_p), intent(in) :: rootid !< MPI task to gather on
1146  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1147  character(*),optional,intent(in):: string !< to identify caller
1148 
1149  !----- local -----
1150  integer(ip_i4_p) :: ierr ! Error code
1151 
1152  !----- formats -----
1153  character(*),parameter :: subname = '(oasis_mpi_gathervr1)'
1154 
1155 !-------------------------------------------------------------------------------
1156 ! PURPOSE: Gather a 1D array of reals
1157 !-------------------------------------------------------------------------------
1158 
1159  call oasis_debug_enter(subname)
1160 
1161  call mpi_gatherv( locarr, locsize, mpi_real8, glob1darr, globsize, displs, &
1162  mpi_real8, rootid, comm, ierr )
1163  if (present(string)) then
1164  call oasis_mpi_chkerr(ierr,subname//trim(string))
1165  else
1166  call oasis_mpi_chkerr(ierr,subname)
1167  endif
1168 
1169  call oasis_debug_exit(subname)
1170 
1171 END SUBROUTINE oasis_mpi_gathervr1
1172 
1173 !===============================================================================
1174 !===============================================================================
1175 
1176 !> Scatter a vector of global data from a rootid
1177 
1178 !> This method passes in glob1DArr, globSize, and displs computed
1179 !> in the oasis_mpi_gathscatvinit routine and uses that information to
1180 !> scatter glob1Darr on processor rootid in communicator comm to locarr
1181 !> on other processors.
1182 
1183 SUBROUTINE oasis_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, &
1184  comm, string )
1185 
1186  IMPLICIT none
1187 
1188  !----- arguments -----
1189  real(ip_double_p),intent(out) :: locarr(:) !< Local array
1190  real(ip_double_p),intent(in) :: glob1Darr(:) !< Global 1D array to send from
1191  integer(ip_i4_p), intent(in) :: locSize !< Number to receive this PE
1192  integer(ip_i4_p), intent(in) :: globSize(:) !< Number to send to each PE
1193  integer(ip_i4_p), intent(in) :: displs(:) !< Displacements for send
1194  integer(ip_i4_p), intent(in) :: rootid !< MPI task to scatter on
1195  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1196  character(*),optional,intent(in):: string !< to identify caller
1197 
1198  !----- local -----
1199  integer(ip_i4_p) :: ierr ! Error code
1200 
1201  !----- formats -----
1202  character(*),parameter :: subname = '(oasis_mpi_scattervr1)'
1203 
1204 !-------------------------------------------------------------------------------
1205 ! PURPOSE: Scatter a 1D array of reals
1206 !-------------------------------------------------------------------------------
1207 
1208  call oasis_debug_enter(subname)
1209 
1210  call mpi_scatterv( glob1darr, globsize, displs, mpi_real8, locarr, locsize, &
1211  mpi_real8, rootid, comm, ierr )
1212  if (present(string)) then
1213  call oasis_mpi_chkerr(ierr,subname//trim(string))
1214  else
1215  call oasis_mpi_chkerr(ierr,subname)
1216  endif
1217 
1218  call oasis_debug_exit(subname)
1219 
1220 END SUBROUTINE oasis_mpi_scattervr1
1221 
1222 
1223 !===============================================================================
1224 !===============================================================================
1225 
1226 !> Compute a global Sum for a scalar integer
1227 
1228 SUBROUTINE oasis_mpi_sumi0(lvec,gvec,comm,string,all)
1229 
1230  IMPLICIT none
1231 
1232  !----- arguments ---
1233  integer(ip_i4_p), intent(in) :: lvec !< local values
1234  integer(ip_i4_p), intent(out):: gvec !< global values
1235  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1236  character(*),optional,intent(in) :: string !< to identify caller
1237  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1238 
1239  !----- local ---
1240  character(*),parameter :: subname = '(oasis_mpi_sumi0)'
1241  logical :: lall
1242  character(len=256) :: lstring
1243  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1244  integer(ip_i4_p) :: lsize
1245  integer(ip_i4_p) :: gsize
1246  integer(ip_i4_p) :: ierr
1247 
1248 !-------------------------------------------------------------------------------
1249 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1250 ! already computed
1251 !-------------------------------------------------------------------------------
1252 
1253  call oasis_debug_enter(subname)
1254 
1255  reduce_type = mpi_sum
1256  if (present(all)) then
1257  lall = all
1258  else
1259  lall = .false.
1260  endif
1261  if (present(string)) then
1262  lstring = trim(subname)//":"//trim(string)
1263  else
1264  lstring = trim(subname)
1265  endif
1266 
1267  lsize = 1
1268  gsize = 1
1269 
1270  if (lsize /= gsize) then
1271  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1272  endif
1273 
1274  if (lall) then
1275  call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
1276  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1277  else
1278  call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
1279  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1280  endif
1281 
1282  call oasis_debug_exit(subname)
1283 
1284 END SUBROUTINE oasis_mpi_sumi0
1285 
1286 !===============================================================================
1287 !===============================================================================
1288 
1289 !> Compute a 1D array of global sums for an array of 1D integers
1290 
1291 !> This sums an array of local integers to an array of summed integers.
1292 !> This does not reduce the array to a scalar.
1293 
1294 SUBROUTINE oasis_mpi_sumi1(lvec,gvec,comm,string,all)
1295 
1296  IMPLICIT none
1297 
1298  !----- arguments ---
1299  integer(ip_i4_p), intent(in) :: lvec(:) !< local values
1300  integer(ip_i4_p), intent(out):: gvec(:) !< global values
1301  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1302  character(*),optional,intent(in) :: string !< to identify caller
1303  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1304 
1305  !----- local ---
1306  character(*),parameter :: subname = '(oasis_mpi_sumi1)'
1307  logical :: lall
1308  character(len=256) :: lstring
1309  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1310  integer(ip_i4_p) :: lsize
1311  integer(ip_i4_p) :: gsize
1312  integer(ip_i4_p) :: ierr
1313 
1314 !-------------------------------------------------------------------------------
1315 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1316 ! already computed
1317 !-------------------------------------------------------------------------------
1318 
1319  call oasis_debug_enter(subname)
1320 
1321  reduce_type = mpi_sum
1322  if (present(all)) then
1323  lall = all
1324  else
1325  lall = .false.
1326  endif
1327  if (present(string)) then
1328  lstring = trim(subname)//":"//trim(string)
1329  else
1330  lstring = trim(subname)
1331  endif
1332 
1333  lsize = size(lvec)
1334  gsize = size(gvec)
1335 
1336  if (lsize /= gsize) then
1337  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1338  endif
1339 
1340  if (lall) then
1341  call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
1342  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1343  else
1344  call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
1345  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1346  endif
1347 
1348  call oasis_debug_exit(subname)
1349 
1350 END SUBROUTINE oasis_mpi_sumi1
1351 
1352 !===============================================================================
1353 !===============================================================================
1354 
1355 !> Compute a global sum for a scalar 8 byte integer
1356 
1357 SUBROUTINE oasis_mpi_sumb0(lvec,gvec,comm,string,all)
1358 
1359  IMPLICIT none
1360 
1361  !----- arguments ---
1362  integer(ip_i8_p), intent(in) :: lvec !< local values
1363  integer(ip_i8_p), intent(out):: gvec !< global values
1364  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1365  character(*),optional,intent(in) :: string !< to identify caller
1366  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1367 
1368  !----- local ---
1369  character(*),parameter :: subname = '(oasis_mpi_sumb0)'
1370  logical :: lall
1371  character(len=256) :: lstring
1372  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1373  integer(ip_i4_p) :: lsize
1374  integer(ip_i4_p) :: gsize
1375  integer(ip_i4_p) :: ierr
1376 
1377 !-------------------------------------------------------------------------------
1378 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1379 ! already computed
1380 !-------------------------------------------------------------------------------
1381 
1382  call oasis_debug_enter(subname)
1383 
1384  reduce_type = mpi_sum
1385  if (present(all)) then
1386  lall = all
1387  else
1388  lall = .false.
1389  endif
1390  if (present(string)) then
1391  lstring = trim(subname)//":"//trim(string)
1392  else
1393  lstring = trim(subname)
1394  endif
1395 
1396  lsize = 1
1397  gsize = 1
1398 
1399  if (lsize /= gsize) then
1400  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1401  endif
1402 
1403  if (lall) then
1404  call mpi_allreduce(lvec,gvec,gsize,mpi_integer8,reduce_type,comm,ierr)
1405  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1406  else
1407  call mpi_reduce(lvec,gvec,gsize,mpi_integer8,reduce_type,0,comm,ierr)
1408  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1409  endif
1410 
1411  call oasis_debug_exit(subname)
1412 
1413 END SUBROUTINE oasis_mpi_sumb0
1414 
1415 !===============================================================================
1416 !===============================================================================
1417 
1418 !> Compute a 1D array of global sums for an array of 1D 8 byte integers
1419 
1420 !> This sums an array of local integers to an array of summed integers.
1421 !> This does not reduce the array to a scalar.
1422 
1423 SUBROUTINE oasis_mpi_sumb1(lvec,gvec,comm,string,all)
1424 
1425  IMPLICIT none
1426 
1427  !----- arguments ---
1428  integer(ip_i8_p), intent(in) :: lvec(:) !< local values
1429  integer(ip_i8_p), intent(out):: gvec(:) !< global values
1430  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1431  character(*),optional,intent(in) :: string !< to identify caller
1432  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1433 
1434  !----- local ---
1435  character(*),parameter :: subname = '(oasis_mpi_sumb1)'
1436  logical :: lall
1437  character(len=256) :: lstring
1438  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1439  integer(ip_i4_p) :: lsize
1440  integer(ip_i4_p) :: gsize
1441  integer(ip_i4_p) :: ierr
1442 
1443 !-------------------------------------------------------------------------------
1444 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1445 ! already computed
1446 !-------------------------------------------------------------------------------
1447 
1448  call oasis_debug_enter(subname)
1449 
1450  reduce_type = mpi_sum
1451  if (present(all)) then
1452  lall = all
1453  else
1454  lall = .false.
1455  endif
1456  if (present(string)) then
1457  lstring = trim(subname)//":"//trim(string)
1458  else
1459  lstring = trim(subname)
1460  endif
1461 
1462  lsize = size(lvec)
1463  gsize = size(gvec)
1464 
1465  if (lsize /= gsize) then
1466  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1467  endif
1468 
1469  if (lall) then
1470  call mpi_allreduce(lvec,gvec,gsize,mpi_integer8,reduce_type,comm,ierr)
1471  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1472  else
1473  call mpi_reduce(lvec,gvec,gsize,mpi_integer8,reduce_type,0,comm,ierr)
1474  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1475  endif
1476 
1477  call oasis_debug_exit(subname)
1478 
1479 END SUBROUTINE oasis_mpi_sumb1
1480 
1481 !===============================================================================
1482 !===============================================================================
1483 
1484 !> Compute a global sum for a scalar double
1485 
1486 SUBROUTINE oasis_mpi_sumr0(lvec,gvec,comm,string,all)
1487 
1488  IMPLICIT none
1489 
1490  !----- arguments ---
1491  real(ip_double_p), intent(in) :: lvec !< local values
1492  real(ip_double_p), intent(out):: gvec !< global values
1493  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1494  character(*),optional,intent(in) :: string !< to identify caller
1495  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1496 
1497  !----- local ---
1498  character(*),parameter :: subname = '(oasis_mpi_sumr0)'
1499  logical :: lall
1500  character(len=256) :: lstring
1501  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1502  integer(ip_i4_p) :: lsize
1503  integer(ip_i4_p) :: gsize
1504  integer(ip_i4_p) :: ierr
1505 
1506 !-------------------------------------------------------------------------------
1507 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1508 ! already computed
1509 !-------------------------------------------------------------------------------
1510 
1511  call oasis_debug_enter(subname)
1512 
1513  reduce_type = mpi_sum
1514  if (present(all)) then
1515  lall = all
1516  else
1517  lall = .false.
1518  endif
1519  if (present(string)) then
1520  lstring = trim(subname)//":"//trim(string)
1521  else
1522  lstring = trim(subname)
1523  endif
1524 
1525  lsize = 1
1526  gsize = 1
1527 
1528  if (lsize /= gsize) then
1529  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1530  endif
1531 
1532  if (lall) then
1533  call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1534  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1535  else
1536  call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1537  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1538  endif
1539 
1540  call oasis_debug_exit(subname)
1541 
1542 END SUBROUTINE oasis_mpi_sumr0
1543 
1544 !===============================================================================
1545 !===============================================================================
1546 
1547 !> Compute a 1D array of global sums for an array of 1D doubles
1548 
1549 !> This sums an array of local doubles to an array of summed doubles.
1550 !> This does not reduce the array to a scalar.
1551 
1552 SUBROUTINE oasis_mpi_sumr1(lvec,gvec,comm,string,all)
1553 
1554  IMPLICIT none
1555 
1556  !----- arguments ---
1557  real(ip_double_p), intent(in) :: lvec(:) !< local values
1558  real(ip_double_p), intent(out):: gvec(:) !< global values
1559  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1560  character(*),optional,intent(in) :: string !< to identify caller
1561  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1562 
1563  !----- local ---
1564  character(*),parameter :: subname = '(oasis_mpi_sumr1)'
1565  logical :: lall
1566  character(len=256) :: lstring
1567  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1568  integer(ip_i4_p) :: lsize
1569  integer(ip_i4_p) :: gsize
1570  integer(ip_i4_p) :: ierr
1571 
1572 !-------------------------------------------------------------------------------
1573 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1574 ! already computed
1575 !-------------------------------------------------------------------------------
1576 
1577  call oasis_debug_enter(subname)
1578 
1579  reduce_type = mpi_sum
1580  if (present(all)) then
1581  lall = all
1582  else
1583  lall = .false.
1584  endif
1585  if (present(string)) then
1586  lstring = trim(subname)//":"//trim(string)
1587  else
1588  lstring = trim(subname)
1589  endif
1590 
1591  lsize = size(lvec)
1592  gsize = size(gvec)
1593 
1594  if (lsize /= gsize) then
1595  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1596  endif
1597 
1598  if (lall) then
1599  call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1600  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1601  else
1602  call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1603  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1604  endif
1605 
1606  call oasis_debug_exit(subname)
1607 
1608 END SUBROUTINE oasis_mpi_sumr1
1609 
1610 !===============================================================================
1611 !===============================================================================
1612 
1613 !> Compute a 2D array of global sums for an array of 2D doubles
1614 
1615 !> This sums an array of local doubles to an array of summed doubles.
1616 !> This does not reduce the array to a scalar.
1617 
1618 SUBROUTINE oasis_mpi_sumr2(lvec,gvec,comm,string,all)
1619 
1620  IMPLICIT none
1621 
1622  !----- arguments ---
1623  real(ip_double_p), intent(in) :: lvec(:,:)!< local values
1624  real(ip_double_p), intent(out):: gvec(:,:)!< global values
1625  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1626  character(*),optional,intent(in) :: string !< to identify caller
1627  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1628 
1629  !----- local ---
1630  character(*),parameter :: subname = '(oasis_mpi_sumr2)'
1631  logical :: lall
1632  character(len=256) :: lstring
1633  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1634  integer(ip_i4_p) :: lsize
1635  integer(ip_i4_p) :: gsize
1636  integer(ip_i4_p) :: ierr
1637 
1638 !-------------------------------------------------------------------------------
1639 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1640 ! already computed
1641 !-------------------------------------------------------------------------------
1642 
1643  call oasis_debug_enter(subname)
1644 
1645  reduce_type = mpi_sum
1646  if (present(all)) then
1647  lall = all
1648  else
1649  lall = .false.
1650  endif
1651  if (present(string)) then
1652  lstring = trim(subname)//":"//trim(string)
1653  else
1654  lstring = trim(subname)
1655  endif
1656 
1657  lsize = size(lvec)
1658  gsize = size(gvec)
1659 
1660  if (lsize /= gsize) then
1661  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1662  endif
1663 
1664  if (lall) then
1665  call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1666  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1667  else
1668  call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1669  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1670  endif
1671 
1672  call oasis_debug_exit(subname)
1673 
1674 END SUBROUTINE oasis_mpi_sumr2
1675 
1676 !===============================================================================
1677 !===============================================================================
1678 
1679 !> Compute a 3D array of global sums for an array of 3D doubles
1680 
1681 !> This sums an array of local doubles to an array of summed doubles.
1682 !> This does not reduce the array to a scalar.
1683 
1684 SUBROUTINE oasis_mpi_sumr3(lvec,gvec,comm,string,all)
1685 
1686  IMPLICIT none
1687 
1688  !----- arguments ---
1689  real(ip_double_p), intent(in) :: lvec(:,:,:) !< local values
1690  real(ip_double_p), intent(out):: gvec(:,:,:) !< global values
1691  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1692  character(*),optional,intent(in) :: string !< to identify caller
1693  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1694 
1695  !----- local ---
1696  character(*),parameter :: subname = '(oasis_mpi_sumr3)'
1697  logical :: lall
1698  character(len=256) :: lstring
1699  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1700  integer(ip_i4_p) :: lsize
1701  integer(ip_i4_p) :: gsize
1702  integer(ip_i4_p) :: ierr
1703 
1704 !-------------------------------------------------------------------------------
1705 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1706 ! already computed
1707 !-------------------------------------------------------------------------------
1708 
1709  call oasis_debug_enter(subname)
1710 
1711  reduce_type = mpi_sum
1712  if (present(all)) then
1713  lall = all
1714  else
1715  lall = .false.
1716  endif
1717  if (present(string)) then
1718  lstring = trim(subname)//":"//trim(string)
1719  else
1720  lstring = trim(subname)
1721  endif
1722 
1723  lsize = size(lvec)
1724  gsize = size(gvec)
1725 
1726  if (lsize /= gsize) then
1727  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1728  endif
1729 
1730  if (lall) then
1731  call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1732  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1733  else
1734  call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1735  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1736  endif
1737 
1738  call oasis_debug_exit(subname)
1739 
1740 END SUBROUTINE oasis_mpi_sumr3
1741 
1742 !===============================================================================
1743 !===============================================================================
1744 
1745 !> Compute a global minimum for a scalar integer
1746 
1747 SUBROUTINE oasis_mpi_mini0(lvec,gvec,comm,string,all)
1748 
1749  IMPLICIT none
1750 
1751  !----- arguments ---
1752  integer(ip_i4_p), intent(in) :: lvec !< local values
1753  integer(ip_i4_p), intent(out):: gvec !< global values
1754  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1755  character(*),optional,intent(in) :: string !< to identify caller
1756  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1757 
1758  !----- local ---
1759  character(*),parameter :: subname = '(oasis_mpi_mini0)'
1760  logical :: lall
1761  character(len=256) :: lstring
1762  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1763  integer(ip_i4_p) :: lsize
1764  integer(ip_i4_p) :: gsize
1765  integer(ip_i4_p) :: ierr
1766 
1767 !-------------------------------------------------------------------------------
1768 ! PURPOSE: Finds min of a distributed vector of values, assume local min
1769 ! already computed
1770 !-------------------------------------------------------------------------------
1771 
1772  call oasis_debug_enter(subname)
1773 
1774  reduce_type = mpi_min
1775  if (present(all)) then
1776  lall = all
1777  else
1778  lall = .false.
1779  endif
1780  if (present(string)) then
1781  lstring = trim(subname)//":"//trim(string)
1782  else
1783  lstring = trim(subname)
1784  endif
1785 
1786  lsize = 1
1787  gsize = 1
1788 
1789  if (lsize /= gsize) then
1790  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1791  endif
1792 
1793  if (lall) then
1794  call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
1795  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1796  else
1797  call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
1798  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1799  endif
1800 
1801  call oasis_debug_exit(subname)
1802 
1803 END SUBROUTINE oasis_mpi_mini0
1804 
1805 !===============================================================================
1806 !===============================================================================
1807 
1808 !> Compute an array of global minimums for an array of 1D integers
1809 
1810 SUBROUTINE oasis_mpi_mini1(lvec,gvec,comm,string,all)
1811 
1812  IMPLICIT none
1813 
1814  !----- arguments ---
1815  integer(ip_i4_p), intent(in) :: lvec(:) !< local values
1816  integer(ip_i4_p), intent(out):: gvec(:) !< global values
1817  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1818  character(*),optional,intent(in) :: string !< to identify caller
1819  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1820 
1821  !----- local ---
1822  character(*),parameter :: subname = '(oasis_mpi_mini1)'
1823  logical :: lall
1824  character(len=256) :: lstring
1825  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1826  integer(ip_i4_p) :: lsize
1827  integer(ip_i4_p) :: gsize
1828  integer(ip_i4_p) :: ierr
1829 
1830 !-------------------------------------------------------------------------------
1831 ! PURPOSE: Finds min of a distributed vector of values, assume local min
1832 ! already computed
1833 !-------------------------------------------------------------------------------
1834 
1835  call oasis_debug_enter(subname)
1836 
1837  reduce_type = mpi_min
1838  if (present(all)) then
1839  lall = all
1840  else
1841  lall = .false.
1842  endif
1843  if (present(string)) then
1844  lstring = trim(subname)//":"//trim(string)
1845  else
1846  lstring = trim(subname)
1847  endif
1848 
1849  lsize = size(lvec)
1850  gsize = size(gvec)
1851 
1852  if (lsize /= gsize) then
1853  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1854  endif
1855 
1856  if (lall) then
1857  call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
1858  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1859  else
1860  call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
1861  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1862  endif
1863 
1864  call oasis_debug_exit(subname)
1865 
1866 END SUBROUTINE oasis_mpi_mini1
1867 
1868 !===============================================================================
1869 !===============================================================================
1870 
1871 !> Compute an global minimum for a scalar double
1872 
1873 SUBROUTINE oasis_mpi_minr0(lvec,gvec,comm,string,all)
1874 
1875  IMPLICIT none
1876 
1877  !----- arguments ---
1878  real(ip_double_p), intent(in) :: lvec !< local values
1879  real(ip_double_p), intent(out):: gvec !< global values
1880  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1881  character(*),optional,intent(in) :: string !< to identify caller
1882  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1883 
1884  !----- local ---
1885  character(*),parameter :: subname = '(oasis_mpi_minr0)'
1886  logical :: lall
1887  character(len=256) :: lstring
1888  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1889  integer(ip_i4_p) :: lsize
1890  integer(ip_i4_p) :: gsize
1891  integer(ip_i4_p) :: ierr
1892 
1893 !-------------------------------------------------------------------------------
1894 ! PURPOSE: Finds min of a distributed vector of values, assume local min
1895 ! already computed
1896 !-------------------------------------------------------------------------------
1897 
1898  call oasis_debug_enter(subname)
1899 
1900  reduce_type = mpi_min
1901  if (present(all)) then
1902  lall = all
1903  else
1904  lall = .false.
1905  endif
1906  if (present(string)) then
1907  lstring = trim(subname)//":"//trim(string)
1908  else
1909  lstring = trim(subname)
1910  endif
1911 
1912  lsize = 1
1913  gsize = 1
1914 
1915  if (lsize /= gsize) then
1916  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1917  endif
1918 
1919  if (lall) then
1920  call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1921  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1922  else
1923  call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1924  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1925  endif
1926 
1927  call oasis_debug_exit(subname)
1928 
1929 END SUBROUTINE oasis_mpi_minr0
1930 
1931 !===============================================================================
1932 !===============================================================================
1933 
1934 !> Compute an array of global minimums for an array of 1D doubles
1935 
1936 SUBROUTINE oasis_mpi_minr1(lvec,gvec,comm,string,all)
1937 
1938  IMPLICIT none
1939 
1940  !----- arguments ---
1941  real(ip_double_p), intent(in) :: lvec(:) !< local values
1942  real(ip_double_p), intent(out):: gvec(:) !< global values
1943  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1944  character(*),optional,intent(in) :: string !< to identify caller
1945  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1946 
1947  !----- local ---
1948  character(*),parameter :: subname = '(oasis_mpi_minr1)'
1949  logical :: lall
1950  character(len=256) :: lstring
1951  integer(ip_i4_p) :: reduce_type ! mpi reduction type
1952  integer(ip_i4_p) :: lsize
1953  integer(ip_i4_p) :: gsize
1954  integer(ip_i4_p) :: ierr
1955 
1956 !-------------------------------------------------------------------------------
1957 ! PURPOSE: Finds min of a distributed vector of values, assume local min
1958 ! already computed
1959 !-------------------------------------------------------------------------------
1960 
1961  call oasis_debug_enter(subname)
1962 
1963  reduce_type = mpi_min
1964  if (present(all)) then
1965  lall = all
1966  else
1967  lall = .false.
1968  endif
1969  if (present(string)) then
1970  lstring = trim(subname)//":"//trim(string)
1971  else
1972  lstring = trim(subname)
1973  endif
1974 
1975  lsize = size(lvec)
1976  gsize = size(gvec)
1977 
1978  if (lsize /= gsize) then
1979  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
1980  endif
1981 
1982  if (lall) then
1983  call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
1984  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1985  else
1986  call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
1987  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1988  endif
1989 
1990  call oasis_debug_exit(subname)
1991 
1992 END SUBROUTINE oasis_mpi_minr1
1993 
1994 !===============================================================================
1995 !===============================================================================
1996 
1997 !> Compute a global maximum for a scalar integer
1998 
1999 SUBROUTINE oasis_mpi_maxi0(lvec,gvec,comm,string,all)
2000 
2001  IMPLICIT none
2002 
2003  !----- arguments ---
2004  integer(ip_i4_p), intent(in) :: lvec !< local values
2005  integer(ip_i4_p), intent(out):: gvec !< global values
2006  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2007  character(*),optional,intent(in) :: string !< to identify caller
2008  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2009 
2010  !----- local ---
2011  character(*),parameter :: subname = '(oasis_mpi_maxi0)'
2012  logical :: lall
2013  character(len=256) :: lstring
2014  integer(ip_i4_p) :: reduce_type ! mpi reduction type
2015  integer(ip_i4_p) :: lsize
2016  integer(ip_i4_p) :: gsize
2017  integer(ip_i4_p) :: ierr
2018 
2019 !-------------------------------------------------------------------------------
2020 ! PURPOSE: Finds max of a distributed vector of values, assume local max
2021 ! already computed
2022 !-------------------------------------------------------------------------------
2023 
2024  call oasis_debug_enter(subname)
2025 
2026  reduce_type = mpi_max
2027  if (present(all)) then
2028  lall = all
2029  else
2030  lall = .false.
2031  endif
2032  if (present(string)) then
2033  lstring = trim(subname)//":"//trim(string)
2034  else
2035  lstring = trim(subname)
2036  endif
2037 
2038  lsize = 1
2039  gsize = 1
2040 
2041  if (lsize /= gsize) then
2042  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
2043  endif
2044 
2045  if (lall) then
2046  call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
2047  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2048  else
2049  call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
2050  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2051  endif
2052 
2053  call oasis_debug_exit(subname)
2054 
2055 END SUBROUTINE oasis_mpi_maxi0
2056 
2057 !===============================================================================
2058 !===============================================================================
2059 
2060 !> Compute an array of global maximums for an array of 1D integers
2061 
2062 SUBROUTINE oasis_mpi_maxi1(lvec,gvec,comm,string,all)
2063 
2064  IMPLICIT none
2065 
2066  !----- arguments ---
2067  integer(ip_i4_p), intent(in) :: lvec(:) !< local values
2068  integer(ip_i4_p), intent(out):: gvec(:) !< global values
2069  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2070  character(*),optional,intent(in) :: string !< to identify caller
2071  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2072 
2073  !----- local ---
2074  character(*),parameter :: subname = '(oasis_mpi_maxi1)'
2075  logical :: lall
2076  character(len=256) :: lstring
2077  integer(ip_i4_p) :: reduce_type ! mpi reduction type
2078  integer(ip_i4_p) :: lsize
2079  integer(ip_i4_p) :: gsize
2080  integer(ip_i4_p) :: ierr
2081 
2082 !-------------------------------------------------------------------------------
2083 ! PURPOSE: Finds max of a distributed vector of values, assume local max
2084 ! already computed
2085 !-------------------------------------------------------------------------------
2086 
2087  call oasis_debug_enter(subname)
2088 
2089  reduce_type = mpi_max
2090  if (present(all)) then
2091  lall = all
2092  else
2093  lall = .false.
2094  endif
2095  if (present(string)) then
2096  lstring = trim(subname)//":"//trim(string)
2097  else
2098  lstring = trim(subname)
2099  endif
2100 
2101  lsize = size(lvec)
2102  gsize = size(gvec)
2103 
2104  if (lsize /= gsize) then
2105  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
2106  endif
2107 
2108  if (lall) then
2109  call mpi_allreduce(lvec,gvec,gsize,mpi_integer,reduce_type,comm,ierr)
2110  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2111  else
2112  call mpi_reduce(lvec,gvec,gsize,mpi_integer,reduce_type,0,comm,ierr)
2113  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2114  endif
2115 
2116  call oasis_debug_exit(subname)
2117 
2118 END SUBROUTINE oasis_mpi_maxi1
2119 
2120 !===============================================================================
2121 !===============================================================================
2122 
2123 !> Compute a global maximum for a scalar double
2124 
2125 SUBROUTINE oasis_mpi_maxr0(lvec,gvec,comm,string,all)
2126 
2127  IMPLICIT none
2128 
2129  !----- arguments ---
2130  real(ip_double_p), intent(in) :: lvec !< local values
2131  real(ip_double_p), intent(out):: gvec !< global values
2132  integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2133  character(*),optional,intent(in) :: string !< to identify caller
2134  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2135 
2136  !----- local ---
2137  character(*),parameter :: subname = '(oasis_mpi_maxr0)'
2138  logical :: lall
2139  character(len=256) :: lstring
2140  integer(ip_i4_p) :: reduce_type ! mpi reduction type
2141  integer(ip_i4_p) :: lsize
2142  integer(ip_i4_p) :: gsize
2143  integer(ip_i4_p) :: ierr
2144 
2145 !-------------------------------------------------------------------------------
2146 ! PURPOSE: Finds max of a distributed vector of values, assume local max
2147 ! already computed
2148 !-------------------------------------------------------------------------------
2149 
2150  call oasis_debug_enter(subname)
2151 
2152  reduce_type = mpi_max
2153  if (present(all)) then
2154  lall = all
2155  else
2156  lall = .false.
2157  endif
2158  if (present(string)) then
2159  lstring = trim(subname)//":"//trim(string)
2160  else
2161  lstring = trim(subname)
2162  endif
2163 
2164  lsize = 1
2165  gsize = 1
2166 
2167  if (lsize /= gsize) then
2168  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
2169  endif
2170 
2171  if (lall) then
2172  call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
2173  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2174  else
2175  call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
2176  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2177  endif
2178 
2179  call oasis_debug_exit(subname)
2180 
2181 END SUBROUTINE oasis_mpi_maxr0
2182 
2183 !===============================================================================
2184 !===============================================================================
2185 
2186 !> Compute an array of global maximums for an array of 1D doubles
2187 
2188 SUBROUTINE oasis_mpi_maxr1(lvec,gvec,comm,string,all)
2189 
2190  IMPLICIT none
2191 
2192  !----- arguments ---
2193  real(ip_double_p), intent(in) :: lvec(:) !< local values
2194  real(ip_double_p), intent(out):: gvec(:) !< global values
2195  integer(ip_i4_p) , intent(in) :: comm !< mpi communicator
2196  character(*),optional,intent(in) :: string !< to identify caller
2197  logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2198 
2199  !----- local ---
2200  character(*),parameter :: subname = '(oasis_mpi_maxr1)'
2201  logical :: lall
2202  character(len=256) :: lstring
2203  integer(ip_i4_p) :: reduce_type ! mpi reduction type
2204  integer(ip_i4_p) :: lsize
2205  integer(ip_i4_p) :: gsize
2206  integer(ip_i4_p) :: ierr
2207 
2208 !-------------------------------------------------------------------------------
2209 ! PURPOSE: Finds max of a distributed vector of values, assume local max
2210 ! already computed
2211 !-------------------------------------------------------------------------------
2212 
2213  call oasis_debug_enter(subname)
2214 
2215  reduce_type = mpi_max
2216  if (present(all)) then
2217  lall = all
2218  else
2219  lall = .false.
2220  endif
2221  if (present(string)) then
2222  lstring = trim(subname)//":"//trim(string)
2223  else
2224  lstring = trim(subname)
2225  endif
2226 
2227  lsize = size(lvec)
2228  gsize = size(gvec)
2229 
2230  if (lsize /= gsize) then
2231  call oasis_mpi_abort(subname//" lsize,gsize incompatable "//trim(string))
2232  endif
2233 
2234  if (lall) then
2235  call mpi_allreduce(lvec,gvec,gsize,mpi_real8,reduce_type,comm,ierr)
2236  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2237  else
2238  call mpi_reduce(lvec,gvec,gsize,mpi_real8,reduce_type,0,comm,ierr)
2239  call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2240  endif
2241 
2242  call oasis_debug_exit(subname)
2243 
2244 END SUBROUTINE oasis_mpi_maxr1
2245 
2246 !===============================================================================
2247 !===============================================================================
2248 
2249 !> Get the total number of tasks associated with a communicator
2250 
2251 SUBROUTINE oasis_mpi_commsize(comm,size,string)
2252 
2253  IMPLICIT none
2254 
2255  !----- arguments ---
2256  integer,intent(in) :: comm !< mpi communicator
2257  integer,intent(out) :: size !< output comm size
2258  character(*),optional,intent(in) :: string !< to identify caller
2259 
2260  !----- local ---
2261  character(*),parameter :: subname = '(oasis_mpi_commsize)'
2262  integer(ip_i4_p) :: ierr
2263 
2264 !-------------------------------------------------------------------------------
2265 ! PURPOSE: MPI commsize
2266 !-------------------------------------------------------------------------------
2267 
2268  call oasis_debug_enter(subname)
2269 
2270  call mpi_comm_size(comm,size,ierr)
2271  if (present(string)) then
2272  call oasis_mpi_chkerr(ierr,subname//trim(string))
2273  else
2274  call oasis_mpi_chkerr(ierr,subname)
2275  endif
2276 
2277  call oasis_debug_exit(subname)
2278 
2279 END SUBROUTINE oasis_mpi_commsize
2280 
2281 !===============================================================================
2282 !===============================================================================
2283 
2284 !> Get the rank (task ID) for a task in a communicator
2285 
2286 SUBROUTINE oasis_mpi_commrank(comm,rank,string)
2287 
2288  IMPLICIT none
2289 
2290  !----- arguments ---
2291  integer,intent(in) :: comm !< mpi communicator
2292  integer,intent(out) :: rank !< output task ID
2293  character(*),optional,intent(in) :: string !< to identify caller
2294 
2295  !----- local ---
2296  character(*),parameter :: subname = '(oasis_mpi_commrank)'
2297  integer(ip_i4_p) :: ierr
2298 
2299 !-------------------------------------------------------------------------------
2300 ! PURPOSE: MPI commrank
2301 !-------------------------------------------------------------------------------
2302 
2303  call oasis_debug_enter(subname)
2304 
2305  call mpi_comm_rank(comm,rank,ierr)
2306  if (present(string)) then
2307  call oasis_mpi_chkerr(ierr,subname//trim(string))
2308  else
2309  call oasis_mpi_chkerr(ierr,subname)
2310  endif
2311 
2312  call oasis_debug_exit(subname)
2313 
2314 END SUBROUTINE oasis_mpi_commrank
2315 
2316 !===============================================================================
2317 !===============================================================================
2318 
2319 !> Check whether MPI has been initialized
2320 
2321 SUBROUTINE oasis_mpi_initialized(flag,string)
2322 
2323  IMPLICIT none
2324 
2325  !----- arguments ---
2326  logical,intent(out) :: flag !< true if MPI_INITIALIZED has been called
2327  character(*),optional,intent(in) :: string !< to identify caller
2328 
2329  !----- local ---
2330  character(*),parameter :: subName = '(oasis_mpi_initialized)'
2331  integer(ip_i4_p) :: ierr
2332 
2333 !-------------------------------------------------------------------------------
2334 ! PURPOSE: MPI initialized
2335 !-------------------------------------------------------------------------------
2336 
2337  call oasis_debug_enter(subname)
2338 
2339  call mpi_initialized(flag,ierr)
2340  if (present(string)) then
2341  call oasis_mpi_chkerr(ierr,subname//trim(string))
2342  else
2343  call oasis_mpi_chkerr(ierr,subname)
2344  endif
2345 
2346  call oasis_debug_exit(subname)
2347 
2348 END SUBROUTINE oasis_mpi_initialized
2349 
2350 !===============================================================================
2351 !===============================================================================
2352 
2353 !> Return a timestamp from MPI_WTIME
2354 
2355 SUBROUTINE oasis_mpi_wtime(wtime)
2356 
2357  IMPLICIT none
2358 
2359  !----- arguments ---
2360  real(ip_r8_p), intent(out) :: wtime !< time in MPI_WTIME units
2361 
2362  !----- local ---
2363  character(*),parameter :: subName = '(oasis_mpi_wtime)'
2364 
2365 !-------------------------------------------------------------------------------
2366 ! PURPOSE: MPI wtime
2367 !-------------------------------------------------------------------------------
2368 
2369  call oasis_debug_enter(subname)
2370 
2371  wtime = mpi_wtime()
2372 
2373  call oasis_debug_exit(subname)
2374 
2375 END SUBROUTINE oasis_mpi_wtime
2376 
2377 !===============================================================================
2378 !===============================================================================
2379 
2380 !> Write error messages and Call MPI_ABORT
2381 
2382 SUBROUTINE oasis_mpi_abort(string,rcode)
2383 
2384  IMPLICIT none
2385 
2386  !----- arguments ---
2387  character(*),optional,intent(in) :: string !< to identify caller
2388  integer,optional,intent(in) :: rcode !< optional code
2389 
2390  !----- local ---
2391  character(*),parameter :: subName = '(oasis_mpi_abort)'
2392  character(len=256) :: lstr
2393  integer(ip_i4_p) :: ierr
2394  integer :: rc ! return code
2395 
2396 !-------------------------------------------------------------------------------
2397 ! PURPOSE: MPI abort
2398 !-------------------------------------------------------------------------------
2399 
2400  call oasis_debug_enter(subname)
2401 
2402  if ( present(string) .and. present(rcode)) then
2403  write(lstr,'(a,i6.6)') trim(string)//' rcode = ',rcode
2404  elseif (present(string)) then
2405  lstr = trim(string)
2406  else
2407  lstr = ' '
2408  endif
2409 
2410  call oasis_abort(cd_routine=subname,cd_message=trim(string))
2411 
2412  call oasis_debug_exit(subname)
2413 
2414 END SUBROUTINE oasis_mpi_abort
2415 
2416 !===============================================================================
2417 !===============================================================================
2418 
2419 !> Call MPI_BARRIER for a particular communicator
2420 
2421 SUBROUTINE oasis_mpi_barrier(comm,string)
2422 
2423  IMPLICIT none
2424 
2425  !----- arguments ---
2426  integer,intent(in) :: comm !< mpi communicator
2427  character(*),optional,intent(in) :: string !< to identify caller
2428 
2429  !----- local ---
2430  character(*),parameter :: subname = '(oasis_mpi_barrier)'
2431  integer(ip_i4_p) :: ierr
2432 
2433 !-------------------------------------------------------------------------------
2434 ! PURPOSE: MPI barrier
2435 !-------------------------------------------------------------------------------
2436 
2437  call oasis_debug_enter(subname)
2438 
2439  call mpi_barrier(comm,ierr)
2440  if (present(string)) then
2441  call oasis_mpi_chkerr(ierr,subname//trim(string))
2442  else
2443  call oasis_mpi_chkerr(ierr,subname)
2444  endif
2445 
2446  call oasis_debug_exit(subname)
2447 
2448 END SUBROUTINE oasis_mpi_barrier
2449 
2450 !===============================================================================
2451 !===============================================================================
2452 
2453 !> Call MPI_INIT
2454 
2455 SUBROUTINE oasis_mpi_init(string)
2456 
2457  IMPLICIT none
2458 
2459  !----- arguments ---
2460  character(*),optional,intent(in) :: string !< to identify caller
2461 
2462  !----- local ---
2463  character(*),parameter :: subname = '(oasis_mpi_init)'
2464  integer(ip_i4_p) :: ierr
2465 
2466 !-------------------------------------------------------------------------------
2467 ! PURPOSE: MPI init
2468 !-------------------------------------------------------------------------------
2469 
2470  call oasis_debug_enter(subname)
2471 
2472  call mpi_init(ierr)
2473  if (present(string)) then
2474  call oasis_mpi_chkerr(ierr,subname//trim(string))
2475  else
2476  call oasis_mpi_chkerr(ierr,subname)
2477  endif
2478 
2479  call oasis_debug_exit(subname)
2480 
2481 END SUBROUTINE oasis_mpi_init
2482 
2483 !===============================================================================
2484 !===============================================================================
2485 
2486 !> Call MPI_FINALZE
2487 
2488 SUBROUTINE oasis_mpi_finalize(string)
2489 
2490  IMPLICIT none
2491 
2492  !----- arguments ---
2493  character(*),optional,intent(in) :: string !< to identify caller
2494 
2495  !----- local ---
2496  character(*),parameter :: subname = '(oasis_mpi_finalize)'
2497  integer(ip_i4_p) :: ierr
2498 
2499 !-------------------------------------------------------------------------------
2500 ! PURPOSE: MPI finalize
2501 !-------------------------------------------------------------------------------
2502 
2503  call oasis_debug_enter(subname)
2504 
2505  call mpi_finalize(ierr)
2506  if (present(string)) then
2507  call oasis_mpi_chkerr(ierr,subname//trim(string))
2508  else
2509  call oasis_mpi_chkerr(ierr,subname)
2510  endif
2511 
2512  call oasis_debug_exit(subname)
2513 
2514 END SUBROUTINE oasis_mpi_finalize
2515 
2516 !===============================================================================
2517 !===============================================================================
2518 
2519 !> Custom method for reducing MPI lists across pes for OASIS
2520 
2521 SUBROUTINE oasis_mpi_reducelists(linp1,comm,cntout,lout1,callstr,fastcheck,fastcheckout, &
2522  linp2,lout2,spval2,linp3,lout3,spval3)
2523 
2524  IMPLICIT none
2525 
2526  !----- arguments ---
2527  character(*),pointer,intent(in) :: linp1(:) !< input list on each task
2528  integer ,intent(in) :: comm !< mpi communicator
2529  integer ,intent(out) :: cntout !< size of lout1 list
2530  character(*),pointer,intent(inout) :: lout1(:) !< reduced output list, same on all tasks
2531  character(*) ,intent(in) :: callstr !< to identify caller
2532  logical ,intent(in) ,optional :: fastcheck !< run a fastcheck first
2533  logical ,intent(out) ,optional :: fastcheckout !< true if fastcheck worked
2534  character(*),pointer,intent(in) ,optional :: linp2(:) !< input list on each task
2535  character(*),pointer,intent(inout),optional :: lout2(:) !< reduced output list, same on all tasks
2536  character(*) ,intent(in) ,optional :: spval2 !< unset value for linp2
2537  integer ,pointer,intent(in) ,optional :: linp3(:) !< input list on each task
2538  integer ,pointer,intent(inout),optional :: lout3(:) !< reduced output list, same on all tasks
2539  integer ,intent(in) ,optional :: spval3 !< unset value for linp3
2540 
2541  !----- local ---
2542  integer(kind=ip_i4_p) :: m,n,k,p
2543  integer(kind=ip_i4_p) :: llen,lsize
2544  integer(kind=ip_i4_p) :: cnt, cntr
2545  integer(kind=ip_i4_p) :: commrank, commsize
2546  integer(kind=ip_i4_p) :: listcheck, listcheckall
2547  integer(kind=ip_i4_p) :: maxloops, sendid, recvid, kfac
2548  logical :: found, present2, present3
2549  integer(kind=ip_i4_p) :: status(mpi_status_size) ! mpi status info
2550  character(len=ic_lvar2),pointer :: recv_varf1(:),varf1a(:),varf1b(:)
2551  character(len=ic_lvar2),pointer :: recv_varf2(:),varf2a(:),varf2b(:)
2552  integer(kind=ip_i4_p) ,pointer :: recv_varf3(:),varf3a(:),varf3b(:)
2553  character(len=ic_lvar2) :: string
2554  logical, parameter :: local_timers_on = .false.
2555  integer(ip_i4_p) :: ierr
2556  character(*),parameter :: subname = '(oasis_mpi_reducelists)'
2557 
2558 !-------------------------------------------------------------------------------
2559 ! PURPOSE: Custom method for reducing MPI lists for OASIS using a log2
2560 ! algorithm. This generates a list on all tasks that consists of the intersection
2561 ! of all the values on all the tasks with each value listed once. linp1
2562 ! is the input list, possibly different on each task. lout1
2563 ! is the resulting list, the same on each task, consistenting of all unique
2564 ! values of linp1 from all tasks. This ultimately reduces the list onto
2565 ! the root task and then it's broadcast. The reduction occurs via a binary
2566 ! type reduction from tasks to other tasks.
2567 !-------------------------------------------------------------------------------
2568 
2569  call oasis_debug_enter(subname)
2570 
2571  string = trim(callstr)
2572  if (present(fastcheckout)) fastcheckout = .false. ! by default
2573  call oasis_mpi_commrank(comm,commrank,string=subname//trim(string))
2574  call oasis_mpi_commsize(comm,commsize,string=subname//trim(string))
2575 
2576  !-----------------------------------------------
2577  !> * Check argument consistency
2578  !-----------------------------------------------
2579 
2580  if ((present(linp2) .and. .not.present(lout2)) .or. &
2581  (present(lout2) .and. .not.present(linp2))) then
2582  call oasis_mpi_abort(subname//trim(string)//" linp2 lout2 both must be present ")
2583  endif
2584  present2 = present(linp2)
2585 
2586  if ((present(linp3) .and. .not.present(lout3)) .or. &
2587  (present(lout3) .and. .not.present(linp3))) then
2588  call oasis_mpi_abort(subname//trim(string)//" linp3 lout3 both must be present ")
2589  endif
2590  present3 = present(linp3)
2591 
2592  if (len(linp1) > len(varf1a)) then
2593  call oasis_mpi_abort(subname//trim(string)//" linp1 too long ")
2594  endif
2595 
2596  if (present(linp2)) then
2597  if (size(linp2) /= size(linp1)) then
2598  call oasis_mpi_abort(subname//trim(string)//" linp1 linp2 not same size ")
2599  endif
2600  if (len(linp2) > len(varf2a)) then
2601  call oasis_mpi_abort(subname//trim(string)//" linp2 too long ")
2602  endif
2603  if (len(varf1a) /= len(varf2a)) then
2604  call oasis_mpi_abort(subname//trim(string)//" varf1a varf2a not same len ")
2605  endif
2606  endif
2607 
2608  if (present(linp3)) then
2609  if (size(linp3) /= size(linp1)) then
2610  call oasis_mpi_abort(subname//trim(string)//" linp1 linp3 not same size ")
2611  endif
2612  endif
2613 
2614  !-----------------------------------------------
2615  !> * Fast compare on all tasks
2616  ! If all tasks have same list, just skip the reduction
2617  !-----------------------------------------------
2618 
2619  if (present(fastcheck)) then
2620  if (fastcheck) then
2621 
2622  if (local_timers_on) call oasis_timer_start(trim(string)//'_rl_fastcheck')
2623 
2624  lsize = -1
2625  if (commrank == 0) then
2626  lsize = size(linp1)
2627  endif
2628  call oasis_mpi_bcast(lsize, comm, subname//trim(string)//' lsize check')
2629 
2630  ! varf1a holds linp1 from root on all tasks
2631  allocate(varf1a(lsize))
2632  varf1a = ' '
2633  if (commrank == 0) then
2634  varf1a(1:lsize) = linp1(1:lsize)
2635  endif
2636  call oasis_mpi_bcast(varf1a, comm, subname//trim(string)//' varf1a check')
2637 
2638  listcheck = 1
2639  if (oasis_debug >= 20) then
2640  write(nulprt,*) subname//trim(string),' sizes ',lsize,size(linp1)
2641  endif
2642  if (lsize /= size(linp1)) listcheck = 0
2643  n = 0
2644  do while (listcheck == 1 .and. n < lsize)
2645  n = n + 1
2646  if (varf1a(n) /= linp1(n)) listcheck = 0
2647  if (oasis_debug >= 20) then
2648  write(nulprt,*) subname//trim(string),' fcheck varf1a ',n,trim(linp1(n)),' ',trim(linp1(n)),listcheck
2649  endif
2650  enddo
2651  deallocate(varf1a)
2652  call oasis_mpi_min(listcheck,listcheckall,comm, subname//trim(string)//' listcheck',all=.true.)
2653 
2654  if (oasis_debug >= 15) then
2655  write(nulprt,*) subname//trim(string),' listcheck = ',listcheck,listcheckall
2656  endif
2657  if (local_timers_on) call oasis_timer_stop(trim(string)//'_rl_fastcheck')
2658 
2659  !-------------------------------------------------
2660  ! linp1 same on all tasks, update lout1, lout2, lout3 and return
2661  !-------------------------------------------------
2662 
2663  if (listcheckall == 1) then
2664  cntout = lsize
2665  allocate(lout1(lsize))
2666  lout1(1:lsize) = linp1(1:lsize)
2667  if (present2) then
2668  allocate(lout2(lsize))
2669  lout2(1:lsize) = linp2(1:lsize)
2670  endif
2671  if (present3) then
2672  allocate(lout3(lsize))
2673  lout3(1:lsize) = linp3(1:lsize)
2674  endif
2675  call oasis_debug_exit(subname)
2676  if (present(fastcheckout)) fastcheckout = .true.
2677  return
2678  endif
2679 
2680  endif ! fastcheck
2681  endif ! present fastcheck
2682 
2683  !-----------------------------------------------
2684  !> * Generate initial unique local name list
2685  !-----------------------------------------------
2686 
2687  llen = len(linp1)
2688  lsize = size(linp1)
2689  if (oasis_debug >= 15) then
2690  write(nulprt,*) subname//trim(string),' len, size = ',llen,lsize
2691  call oasis_flush(nulprt)
2692  endif
2693 
2694  allocate(varf1a(max(lsize,20))) ! 20 is arbitrary starting number
2695  if (present2) allocate(varf2a(max(lsize,20))) ! 20 is arbitrary starting number
2696  if (present3) allocate(varf3a(max(lsize,20))) ! 20 is arbitrary starting number
2697  cnt = 0
2698  do n = 1,lsize
2699  p = 0
2700  found = .false.
2701  do while (p < cnt .and. .not.found)
2702  p = p + 1
2703  if (linp1(n) == varf1a(p)) found = .true.
2704  enddo
2705  if (.not.found) then
2706  cnt = cnt + 1
2707  varf1a(cnt) = linp1(n)
2708  if (present2) varf2a(cnt) = linp2(n)
2709  if (present3) varf3a(cnt) = linp3(n)
2710  endif
2711  enddo
2712 
2713  !-----------------------------------------------
2714  !> * Log2 reduction of linp over tasks to root
2715  !-----------------------------------------------
2716 
2717  maxloops = int(sqrt(float(commsize+1)))+1
2718  do m = 1,maxloops
2719 
2720  kfac = 2**m
2721 
2722  recvid = commrank + kfac/2 ! task to recv from
2723  if (mod(commrank,kfac) /= 0 .or. &
2724  recvid < 0 .or. recvid > commsize-1) &
2725  recvid = -1
2726 
2727  sendid = commrank - kfac/2 ! task to send to
2728  if (mod(commrank+kfac/2,kfac) /= 0 .or. &
2729  sendid < 0 .or. sendid > commsize-1) &
2730  sendid = -1
2731 
2732  if (oasis_debug >= 15) then
2733  write(nulprt,*) subname//trim(string),' send/recv ids ',m,commrank,sendid,recvid
2734  call oasis_flush(nulprt)
2735  endif
2736 
2737  !-----------------------------------------------
2738  !> * Send list
2739  !-----------------------------------------------
2740 
2741  if (sendid >= 0) then
2742  if (local_timers_on) call oasis_timer_start(trim(string)//'_rl_send')
2743  call mpi_send(cnt, 1, mpi_integer, sendid, 5900+m, comm, ierr)
2744  call oasis_mpi_chkerr(ierr,subname//trim(string)//':send cnt')
2745  if (cnt > 0) then
2746  if (oasis_debug >= 15) then
2747  write(nulprt,*) subname//trim(string),' send size ',commrank,m,cnt,ic_lvar2
2748  call oasis_flush(nulprt)
2749  endif
2750  call mpi_send(varf1a(1:cnt), cnt*ic_lvar2, mpi_character, sendid, 6900+m, comm, ierr)
2751  call oasis_mpi_chkerr(ierr,subname//trim(string)//':send varf1a')
2752  if (present2) then
2753  call mpi_send(varf2a(1:cnt), cnt*ic_lvar2, mpi_character, sendid, 7900+m, comm, ierr)
2754  call oasis_mpi_chkerr(ierr,subname//trim(string)//':send varf2a')
2755  endif
2756  if (present3) then
2757  call mpi_send(varf3a(1:cnt), cnt, mpi_integer, sendid, 8900+m, comm, ierr)
2758  call oasis_mpi_chkerr(ierr,subname//trim(string)//':send varf3a')
2759  endif
2760  endif ! cnt > 0
2761  if (local_timers_on) call oasis_timer_stop(trim(string)//'_rl_send')
2762  endif ! sendid >= 0
2763 
2764  !-----------------------------------------------
2765  !> * Recv list
2766  !> * Determine the unique list
2767  !-----------------------------------------------
2768 
2769  if (recvid >= 0) then
2770  if (local_timers_on) call oasis_timer_start(trim(string)//'_rl_recv')
2771  call mpi_recv(cntr, 1, mpi_integer, recvid, 5900+m, comm, status, ierr)
2772  call oasis_mpi_chkerr(ierr,subname//trim(string)//':recv cntr')
2773  if (cntr > 0) then
2774  if (oasis_debug >= 15) then
2775  write(nulprt,*) subname//trim(string),' recv size ',commrank,m,cntr,ic_lvar2
2776  call oasis_flush(nulprt)
2777  endif
2778  allocate(recv_varf1(cntr))
2779  call mpi_recv(recv_varf1, cntr*ic_lvar2, mpi_character, recvid, 6900+m, comm, status, ierr)
2780  call oasis_mpi_chkerr(ierr,subname//trim(string)//':recv varf1')
2781  if (present2) then
2782  allocate(recv_varf2(cntr))
2783  call mpi_recv(recv_varf2, cntr*ic_lvar2, mpi_character, recvid, 7900+m, comm, status, ierr)
2784  call oasis_mpi_chkerr(ierr,subname//trim(string)//':recv varf2')
2785  endif
2786  if (present3) then
2787  allocate(recv_varf3(cntr))
2788  call mpi_recv(recv_varf3, cntr, mpi_integer, recvid, 8900+m, comm, status, ierr)
2789  call oasis_mpi_chkerr(ierr,subname//trim(string)//':recv varf3')
2790  endif
2791  endif ! cntr > 0
2792  if (local_timers_on) call oasis_timer_stop(trim(string)//'_rl_recv')
2793 
2794  if (local_timers_on) call oasis_timer_start(trim(string)//'_rl_rootsrch')
2795  do n = 1,cntr
2796  if (oasis_debug >= 15) write(nulprt,*) subname//trim(string),' check recv_varf1 ',m,n,trim(recv_varf1(n))
2797 
2798  p = 0
2799  found = .false.
2800  do while (p < cnt .and. .not.found)
2801  p = p + 1
2802  if (recv_varf1(n) == varf1a(p)) then
2803  found = .true.
2804  if (present2) then
2805  if (present(spval2)) then
2806  !--- use something other than spval2 if it exists and check consistency
2807  if (varf2a(p) == spval2) then
2808  varf2a(p) = recv_varf2(n)
2809  elseif (recv_varf2(n) /= spval2 .and. varf2a(p) /= recv_varf2(n)) then
2810  call oasis_abort(cd_routine=subname//trim(string),cd_message= &
2811  'inconsistent linp2 value: '//trim(recv_varf2(n))//':'//trim(varf1a(p))//':'//trim(varf2a(p)))
2812  endif
2813  else
2814  if (varf2a(p) /= recv_varf2(n)) then
2815  call oasis_abort(cd_routine=subname//trim(string),cd_message= &
2816  'inconsistent linp2 value: '//trim(recv_varf2(n))//':'//trim(varf1a(p))//':'//trim(varf2a(p)))
2817  endif
2818  endif
2819  endif
2820  if (present3) then
2821  if (present(spval3)) then
2822  !--- use something other than spval3 if it exists and check consistency
2823  if (varf3a(p) == spval3) then
2824  varf3a(p) = recv_varf3(n)
2825  elseif (recv_varf3(n) /= spval3 .and. varf3a(p) /= recv_varf3(n)) then
2826  write(nulprt,*) subname//trim(string),astr,'inconsistent linp3 var: ',&
2827  recv_varf3(n),':',trim(varf1a(p)),':',varf3a(p)
2828  call oasis_abort(cd_routine=subname//trim(string),cd_message= &
2829  'inconsistent linp3 value: '//trim(varf1a(p)))
2830  endif
2831  else
2832  if (varf3a(p) /= recv_varf3(n)) then
2833  write(nulprt,*) subname//trim(string),astr,'inconsistent linp3 var: ',&
2834  recv_varf3(n),':',trim(varf1a(p)),':',varf3a(p)
2835  call oasis_abort(cd_routine=subname//trim(string),cd_message= &
2836  'inconsistent linp3 value: '//trim(varf1a(p)))
2837  endif
2838  endif
2839  endif
2840  endif
2841  enddo
2842  if (.not.found) then
2843  cnt = cnt + 1
2844  if (cnt > size(varf1a)) then
2845  allocate(varf1b(size(varf1a)))
2846  varf1b = varf1a
2847  deallocate(varf1a)
2848  if (oasis_debug >= 15) then
2849  write(nulprt,*) subname//trim(string),' resize varf1a ',size(varf1b),cnt+cntr
2850  call oasis_flush(nulprt)
2851  endif
2852  allocate(varf1a(cnt+cntr))
2853  varf1a(1:size(varf1b)) = varf1b(1:size(varf1b))
2854  deallocate(varf1b)
2855  if (present2) then
2856  allocate(varf2b(size(varf2a)))
2857  varf2b = varf2a
2858  deallocate(varf2a)
2859  if (oasis_debug >= 15) then
2860  write(nulprt,*) subname//trim(string),' resize varf2a ',size(varf2b),cnt+cntr
2861  call oasis_flush(nulprt)
2862  endif
2863  allocate(varf2a(cnt+cntr))
2864  varf2a(1:size(varf2b)) = varf2b(1:size(varf2b))
2865  deallocate(varf2b)
2866  endif
2867  if (present3) then
2868  allocate(varf3b(size(varf3a)))
2869  varf3b = varf3a
2870  deallocate(varf3a)
2871  if (oasis_debug >= 15) then
2872  write(nulprt,*) subname//trim(string),' resize varf3a ',size(varf3b),cnt+cntr
2873  call oasis_flush(nulprt)
2874  endif
2875  allocate(varf3a(cnt+cntr))
2876  varf3a(1:size(varf3b)) = varf3b(1:size(varf3b))
2877  deallocate(varf3b)
2878  endif
2879  endif
2880  varf1a(cnt) = recv_varf1(n)
2881  if (present2) varf2a(cnt) = recv_varf2(n)
2882  if (present3) varf3a(cnt) = recv_varf3(n)
2883  endif
2884  enddo ! cntr
2885  if (local_timers_on) call oasis_timer_stop(trim(string)//'_rl_rootsrch')
2886  if (cntr > 0) then
2887  deallocate(recv_varf1)
2888  if (present2) deallocate(recv_varf2)
2889  if (present3) deallocate(recv_varf3)
2890  endif
2891 
2892  endif ! recvid >= 0
2893 
2894  enddo ! maxloops
2895 
2896  !-------------------------------------------------
2897  !> * Broadcast the list information to all tasks from root
2898  !-------------------------------------------------
2899 
2900  if (local_timers_on) then
2901  call oasis_timer_start(trim(string)//'_rl_bcast_barrier')
2902  if (comm /= mpi_comm_null) &
2903  call mpi_barrier(comm, ierr)
2904  call oasis_timer_stop(trim(string)//'_rl_bcast_barrier')
2905  endif
2906  if (local_timers_on) call oasis_timer_start(trim(string)//'_rl_bcast')
2907  call oasis_mpi_bcast(cnt,comm,subname//trim(string)//' cnt')
2908  cntout = cnt
2909  allocate(lout1(cntout))
2910  if (commrank == 0) then
2911  lout1(1:cntout) = varf1a(1:cntout)
2912  endif
2913  deallocate(varf1a)
2914  call oasis_mpi_bcast(lout1,comm,subname//trim(string)//' lout1')
2915 
2916  if (present2) then
2917  allocate(lout2(cntout))
2918  if (commrank == 0) then
2919  lout2(1:cntout) = varf2a(1:cntout)
2920  endif
2921  deallocate(varf2a)
2922  call oasis_mpi_bcast(lout2,comm,subname//trim(string)//' lout2')
2923  endif
2924 
2925  if (present3) then
2926  allocate(lout3(cntout))
2927  if (commrank == 0) then
2928  lout3(1:cntout) = varf3a(1:cntout)
2929  endif
2930  deallocate(varf3a)
2931  call oasis_mpi_bcast(lout3,comm,subname//trim(string)//' lout3')
2932  endif
2933 
2934  !--- document
2935 
2936  if (oasis_debug >= 15) then
2937  do n = 1,cnt
2938  if (present2 .and. present3) then
2939  write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),' ',trim(lout2(n)),lout3(n)
2940  elseif (present2) then
2941  write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),' ',trim(lout2(n))
2942  elseif (present3) then
2943  write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),lout3(n)
2944  else
2945  write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n))
2946  endif
2947  enddo
2948  call oasis_flush(nulprt)
2949  endif
2950  if (local_timers_on) call oasis_timer_stop(trim(string)//'_rl_bcast')
2951 
2952  call oasis_debug_exit(subname)
2953 
2954 END SUBROUTINE oasis_mpi_reducelists
2955 
2956 !===============================================================================
2957 !===============================================================================
2958 
2959 END MODULE mod_oasis_mpi
subroutine oasis_mpi_bcastr3(arr, comm, string, pebcast)
Broadcast an array of 3D doubles.
Generic overloaded interface into MPI sum reduction.
Generic interfaces into an MPI vector gather.
subroutine oasis_mpi_recvr0(lvec, pid, tag, comm, string)
Receive a scalar double.
subroutine, public oasis_debug_exit(string)
Used when a subroutine is exited, write info to log file at some debug level.
System type methods.
subroutine oasis_mpi_bcasti1(vec, comm, string, pebcast)
Broadcast an array of 1D integers.
subroutine oasis_mpi_sumi1(lvec, gvec, comm, string, all)
Compute a 1D array of global sums for an array of 1D integers.
subroutine oasis_mpi_maxi0(lvec, gvec, comm, string, all)
Compute a global maximum for a scalar integer.
Generic overloaded interface into MPI send.
subroutine oasis_mpi_maxr1(lvec, gvec, comm, string, all)
Compute an array of global maximums for an array of 1D doubles.
Generic overloaded interface into MPI max reduction.
subroutine, public oasis_mpi_initialized(flag, string)
Check whether MPI has been initialized.
Provides a generic and simpler interface into MPI calls for OASIS.
subroutine oasis_mpi_sendi0(lvec, pid, tag, comm, string)
Send a scalar integer.
Generic overloaded interface into MPI broadcast.
subroutine oasis_mpi_mini0(lvec, gvec, comm, string, all)
Compute a global minimum for a scalar integer.
subroutine oasis_mpi_mini1(lvec, gvec, comm, string, all)
Compute an array of global minimums for an array of 1D integers.
subroutine, public oasis_mpi_init(string)
Call MPI_INIT.
subroutine, public oasis_mpi_wtime(wtime)
Return a timestamp from MPI_WTIME.
subroutine oasis_mpi_bcastl1(vec, comm, string, pebcast)
Broadcast an array of 1D logicals.
subroutine, public oasis_mpi_commsize(comm, size, string)
Get the total number of tasks associated with a communicator.
subroutine, public oasis_timer_start(timer_label, barrier)
Start a timer.
subroutine, public oasis_mpi_abort(string, rcode)
Write error messages and Call MPI_ABORT.
subroutine oasis_mpi_recvi0(lvec, pid, tag, comm, string)
Receive a scalar integer.
subroutine, public oasis_timer_stop(timer_label)
Stop a timer.
Provides a common location for several OASIS variables.
Generic interfaces into an MPI vector scatter.
subroutine, public oasis_mpi_reducelists(linp1, comm, cntout, lout1, callstr, fastcheck, fastcheckout, linp2, lout2, spval2, linp3, lout3, spval3)
Custom method for reducing MPI lists across pes for OASIS.
subroutine oasis_mpi_sumi0(lvec, gvec, comm, string, all)
Compute a global Sum for a scalar integer.
subroutine oasis_mpi_bcastr1(vec, comm, string, pebcast)
Broadcast an array of 1D doubles.
subroutine, public oasis_debug_enter(string)
Used when a subroutine is entered, write info to log file at some debug level.
Defines kinds for OASIS.
subroutine, public oasis_flush(nu)
Flushes output to file.
subroutine oasis_mpi_sumr1(lvec, gvec, comm, string, all)
Compute a 1D array of global sums for an array of 1D doubles.
subroutine, public oasis_mpi_commrank(comm, rank, string)
Get the rank (task ID) for a task in a communicator.
subroutine oasis_mpi_minr0(lvec, gvec, comm, string, all)
Compute an global minimum for a scalar double.
Generic overloaded interface into MPI min reduction.
subroutine oasis_mpi_sendi1(lvec, pid, tag, comm, string)
Send an array of 1D integers.
subroutine oasis_mpi_sumr2(lvec, gvec, comm, string, all)
Compute a 2D array of global sums for an array of 2D doubles.
subroutine oasis_mpi_sumr0(lvec, gvec, comm, string, all)
Compute a global sum for a scalar double.
subroutine oasis_mpi_maxi1(lvec, gvec, comm, string, all)
Compute an array of global maximums for an array of 1D integers.
subroutine oasis_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, comm, string)
Gather a vector of distributed data to a rootid.
subroutine oasis_mpi_bcasti0(vec, comm, string, pebcast)
Broadcast a scalar integer.
subroutine, public oasis_mpi_chkerr(rcode, string)
Checks MPI error codes and aborts.
subroutine oasis_mpi_bcasti2(arr, comm, string, pebcast)
Broadcast an array of 2D integers.
Performance timer methods.
Generic interface to oasis_mpi_gathScatVInit.
subroutine oasis_mpi_gathscatvinitr1(comm, rootid, locArr, glob1DArr, globSize, displs, string)
Initialize variables for oasis_mpi_gatherv and oasis_mpi_scatterv.
subroutine, public oasis_abort(id_compid, cd_routine, cd_message)
OASIS abort method, publically available to users.
subroutine oasis_mpi_sendr3(array, pid, tag, comm, string)
Send an array of 3D doubles.
subroutine oasis_mpi_bcastc1(vec, comm, string, pebcast)
Broadcast an array of 1D character strings.
subroutine oasis_mpi_sumb0(lvec, gvec, comm, string, all)
Compute a global sum for a scalar 8 byte integer.
subroutine oasis_mpi_sendr0(lvec, pid, tag, comm, string)
Send a scalar double.
subroutine, public oasis_mpi_finalize(string)
Call MPI_FINALZE.
subroutine oasis_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, comm, string)
Scatter a vector of global data from a rootid.
subroutine, public oasis_mpi_barrier(comm, string)
Call MPI_BARRIER for a particular communicator.
subroutine oasis_mpi_bcastc0(vec, comm, string, pebcast)
Broadcast a character string.
subroutine oasis_mpi_minr1(lvec, gvec, comm, string, all)
Compute an array of global minimums for an array of 1D doubles.
subroutine oasis_mpi_bcastr0(vec, comm, string, pebcast)
Broadcast a scalar double.
subroutine oasis_mpi_bcastl0(vec, comm, string, pebcast)
Broadcast a scalar logical.
subroutine oasis_mpi_recvr1(lvec, pid, tag, comm, string)
Receive an array of 1D doubles.
subroutine oasis_mpi_sumr3(lvec, gvec, comm, string, all)
Compute a 3D array of global sums for an array of 3D doubles.
subroutine oasis_mpi_sendr1(lvec, pid, tag, comm, string)
Send an array of 1D doubles.
subroutine oasis_mpi_bcastr2(arr, comm, string, pebcast)
Broadcast an array of 2D doubles.
subroutine oasis_mpi_maxr0(lvec, gvec, comm, string, all)
Compute a global maximum for a scalar double.
Generic overloaded interface into MPI receive.
subroutine oasis_mpi_sumb1(lvec, gvec, comm, string, all)
Compute a 1D array of global sums for an array of 1D 8 byte integers.
subroutine oasis_mpi_recvi1(lvec, pid, tag, comm, string)
Receive an array of 1D integers.
subroutine oasis_mpi_recvr3(array, pid, tag, comm, string)
Receive an array of 3D doubles.