Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

mod_oasis_mpi.F90 @ 6331

Last change on this file since 6331 was 6331, checked in by aclsce, 17 months ago
Moved oasis-mct_5.0 in oasis3-mct/branches directory.
File size: 125.0 KB

Line
1	!> Provides a generic and simpler interface into MPI calls for OASIS.
2
3	MODULE mod_oasis_mpi
4
5	!-------------------------------------------------------------------------------
6	! PURPOSE: general layer on MPI functions
7	!-------------------------------------------------------------------------------
8
9	use mod_oasis_kinds
10	USE mod_oasis_data ,ONLY: nulprt, OASIS_Debug
11	USE mod_oasis_sys ,ONLY: oasis_debug_enter, oasis_debug_exit, oasis_flush, oasis_abort, astr
12	USE mod_oasis_timer,ONLY: oasis_timer_start, oasis_timer_stop
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_minloc
30	public :: oasis_mpi_maxloc
31	public :: oasis_mpi_commsize
32	public :: oasis_mpi_commrank
33	public :: oasis_mpi_initialized
34	public :: oasis_mpi_wtime
35	public :: oasis_mpi_abort
36	public :: oasis_mpi_barrier
37	public :: oasis_mpi_init
38	public :: oasis_mpi_finalize
39	public :: oasis_mpi_reducelists
40
41	!> Generic overloaded interface into MPI send
42	interface oasis_mpi_send ; module procedure &
43	oasis_mpi_sendi0, &
44	oasis_mpi_sendi1, &
45	oasis_mpi_sendr0, &
46	oasis_mpi_sendr1, &
47	oasis_mpi_sendr3
48	end interface
49
50	!> Generic overloaded interface into MPI receive
51	interface oasis_mpi_recv ; module procedure &
52	oasis_mpi_recvi0, &
53	oasis_mpi_recvi1, &
54	oasis_mpi_recvr0, &
55	oasis_mpi_recvr1, &
56	oasis_mpi_recvr3
57	end interface
58
59	!> Generic overloaded interface into MPI broadcast
60	interface oasis_mpi_bcast ; module procedure &
61	oasis_mpi_bcastc0, &
62	oasis_mpi_bcastc1, &
63	oasis_mpi_bcastl0, &
64	oasis_mpi_bcastl1, &
65	oasis_mpi_bcasti0, &
66	oasis_mpi_bcasti1, &
67	oasis_mpi_bcasti2, &
68	oasis_mpi_bcastr0, &
69	oasis_mpi_bcastr1, &
70	oasis_mpi_bcastr2, &
71	oasis_mpi_bcastr3
72	end interface
73
74	!> Generic interface to oasis_mpi_gathScatVInit
75	interface oasis_mpi_gathScatVInit ; module procedure &
76	oasis_mpi_gathScatVInitr1
77	end interface
78
79	!> Generic interfaces into an MPI vector gather
80	interface oasis_mpi_gatherv ; module procedure &
81	oasis_mpi_gatherVr1
82	end interface
83
84	!> Generic interfaces into an MPI vector scatter
85	interface oasis_mpi_scatterv ; module procedure &
86	oasis_mpi_scatterVr1
87	end interface
88
89	!> Generic overloaded interface into MPI sum reduction
90	interface oasis_mpi_sum ; module procedure &
91	oasis_mpi_sumi0, &
92	oasis_mpi_sumi1, &
93	oasis_mpi_sumb0, &
94	oasis_mpi_sumb1, &
95	#ifndef __NO_16BYTE_REALS
96	oasis_mpi_sumq0, &
97	oasis_mpi_sumq1, &
98	oasis_mpi_sumq2, &
99	oasis_mpi_sumq3, &
100	#endif
101	oasis_mpi_sumr0, &
102	oasis_mpi_sumr1, &
103	oasis_mpi_sumr2, &
104	oasis_mpi_sumr3
105	end interface
106
107	!> Generic overloaded interface into MPI min reduction
108	interface oasis_mpi_min ; module procedure &
109	oasis_mpi_mini0, &
110	oasis_mpi_mini1, &
111	oasis_mpi_minr0, &
112	oasis_mpi_minr1
113	end interface
114
115	!> Generic overloaded interface into MPI max reduction
116	interface oasis_mpi_max ; module procedure &
117	oasis_mpi_maxi0, &
118	oasis_mpi_maxi1, &
119	oasis_mpi_maxr0, &
120	oasis_mpi_maxr1
121	end interface
122
123	!> Generic overloaded interface into MPI min reduction
124	interface oasis_mpi_minloc ; module procedure &
125	oasis_mpi_minloci, &
126	oasis_mpi_minlocr
127	end interface
128
129	!> Generic overloaded interface into MPI max reduction
130	interface oasis_mpi_maxloc ; module procedure &
131	oasis_mpi_maxloci, &
132	oasis_mpi_maxlocr
133	end interface
134
135	! mpi library include file
136	#include <mpif.h>
137
138	!===============================================================================
139	CONTAINS
140	!===============================================================================
141
142	!> Checks MPI error codes and aborts
143
144	!> This method compares rcode to MPI_SUCCESS. If rcode is an error,
145	!> it queries MPI_ERROR_STRING for the error string associated with rcode, writes
146	!> it out, and aborts with the string passed through the interface.
147
148	SUBROUTINE oasis_mpi_chkerr(rcode,string)
149
150	IMPLICIT none
151
152	!----- arguments ---
153	integer(ip_i4_p), intent(in) :: rcode !< MPI error code
154	character(*), intent(in) :: string !< abort message
155
156	!----- local ---
157	character(*),parameter :: subname = '(oasis_mpi_chkerr)'
158	character(MPI_MAX_ERROR_STRING) :: lstring
159	integer(ip_i4_p) :: len
160	integer(ip_i4_p) :: ierr
161
162	!-------------------------------------------------------------------------------
163	! PURPOSE: layer on MPI error checking
164	!-------------------------------------------------------------------------------
165
166	call oasis_debug_enter(subname)
167
168	lstring = ' '
169	if (rcode /= MPI_SUCCESS) then
170	call MPI_ERROR_STRING(rcode,lstring,len,ierr)
171	call oasis_mpi_abort(subname//trim(string)//':'//trim(lstring),rcode)
172	endif
173
174	call oasis_debug_exit(subname)
175
176	END SUBROUTINE oasis_mpi_chkerr
177
178	!===============================================================================
179	!===============================================================================
180
181	!> Send a scalar integer
182
183	SUBROUTINE oasis_mpi_sendi0(lvec,pid,tag,comm,string)
184
185	IMPLICIT none
186
187	!----- arguments ---
188	integer(ip_i4_p), intent(in) :: lvec !< send value
189	integer(ip_i4_p), intent(in) :: pid !< pid to send to
190	integer(ip_i4_p), intent(in) :: tag !< mpi tag
191	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
192	character(*),optional,intent(in) :: string !< to identify caller
193
194	!----- local ---
195	character(*),parameter :: subname = '(oasis_mpi_sendi0)'
196	integer(ip_i4_p) :: lsize
197	integer(ip_i4_p) :: ierr
198
199	!-------------------------------------------------------------------------------
200	! PURPOSE: Send a single integer
201	!-------------------------------------------------------------------------------
202
203	call oasis_debug_enter(subname)
204
205	lsize = 1
206
207	call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr)
208	if (present(string)) then
209	call oasis_mpi_chkerr(ierr,subName//trim(string))
210	else
211	call oasis_mpi_chkerr(ierr,subName)
212	endif
213
214	call oasis_debug_exit(subname)
215
216	END SUBROUTINE oasis_mpi_sendi0
217
218	!===============================================================================
219	!===============================================================================
220
221	!> Send an array of 1D integers
222
223	SUBROUTINE oasis_mpi_sendi1(lvec,pid,tag,comm,string)
224
225	IMPLICIT none
226
227	!----- arguments ---
228	integer(ip_i4_p), intent(in) :: lvec(:) !< send values
229	integer(ip_i4_p), intent(in) :: pid !< pid to send to
230	integer(ip_i4_p), intent(in) :: tag !< mpi tag
231	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
232	character(*),optional,intent(in) :: string !< to identify caller
233
234	!----- local ---
235	character(*),parameter :: subname = '(oasis_mpi_sendi1)'
236	integer(ip_i4_p) :: lsize
237	integer(ip_i4_p) :: ierr
238
239	!-------------------------------------------------------------------------------
240	! PURPOSE: Send a vector of integers
241	!-------------------------------------------------------------------------------
242
243	call oasis_debug_enter(subname)
244
245	lsize = size(lvec)
246
247	call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr)
248	if (present(string)) then
249	call oasis_mpi_chkerr(ierr,subName//trim(string))
250	else
251	call oasis_mpi_chkerr(ierr,subName)
252	endif
253
254	call oasis_debug_exit(subname)
255
256	END SUBROUTINE oasis_mpi_sendi1
257
258	!===============================================================================
259	!===============================================================================
260
261	!> Send a scalar double
262
263	SUBROUTINE oasis_mpi_sendr0(lvec,pid,tag,comm,string)
264
265	IMPLICIT none
266
267	!----- arguments ---
268	real(ip_double_p),intent(in) :: lvec !< send values
269	integer(ip_i4_p), intent(in) :: pid !< pid to send to
270	integer(ip_i4_p), intent(in) :: tag !< mpi tag
271	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
272	character(*),optional,intent(in) :: string !< to identify caller
273
274	!----- local ---
275	character(*),parameter :: subname = '(oasis_mpi_sendr0)'
276	integer(ip_i4_p) :: lsize
277	integer(ip_i4_p) :: ierr
278
279	!-------------------------------------------------------------------------------
280	! PURPOSE: Send a real scalar
281	!-------------------------------------------------------------------------------
282
283	call oasis_debug_enter(subname)
284
285	lsize = 1
286
287	call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr)
288	if (present(string)) then
289	call oasis_mpi_chkerr(ierr,subName//trim(string))
290	else
291	call oasis_mpi_chkerr(ierr,subName)
292	endif
293
294	call oasis_debug_exit(subname)
295
296	END SUBROUTINE oasis_mpi_sendr0
297
298	!===============================================================================
299	!===============================================================================
300
301	!> Send an array of 1D doubles
302
303	SUBROUTINE oasis_mpi_sendr1(lvec,pid,tag,comm,string)
304
305	IMPLICIT none
306
307	!----- arguments ---
308	real(ip_double_p),intent(in) :: lvec(:) !< send values
309	integer(ip_i4_p), intent(in) :: pid !< pid to send to
310	integer(ip_i4_p), intent(in) :: tag !< mpi tag
311	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
312	character(*),optional,intent(in) :: string !< to identify caller
313
314	!----- local ---
315	character(*),parameter :: subname = '(oasis_mpi_sendr1)'
316	integer(ip_i4_p) :: lsize
317	integer(ip_i4_p) :: ierr
318
319	!-------------------------------------------------------------------------------
320	! PURPOSE: Send a vector of reals
321	!-------------------------------------------------------------------------------
322
323	call oasis_debug_enter(subname)
324
325	lsize = size(lvec)
326
327	call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr)
328	if (present(string)) then
329	call oasis_mpi_chkerr(ierr,subName//trim(string))
330	else
331	call oasis_mpi_chkerr(ierr,subName)
332	endif
333
334	call oasis_debug_exit(subname)
335
336	END SUBROUTINE oasis_mpi_sendr1
337
338	!===============================================================================
339	!===============================================================================
340
341	!> Send an array of 3D doubles
342
343	SUBROUTINE oasis_mpi_sendr3(array,pid,tag,comm,string)
344
345	IMPLICIT none
346
347	!----- arguments ---
348	real(ip_double_p),intent(in) :: array(:,:,:) !< send values
349	integer(ip_i4_p), intent(in) :: pid !< pid to send to
350	integer(ip_i4_p), intent(in) :: tag !< mpi tag
351	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
352	character(*),optional,intent(in) :: string !< to identify caller
353
354	!----- local ---
355	character(*),parameter :: subname = '(oasis_mpi_sendr3)'
356	integer(ip_i4_p) :: lsize
357	integer(ip_i4_p) :: ierr
358
359	!-------------------------------------------------------------------------------
360	! PURPOSE: Send a vector of reals
361	!-------------------------------------------------------------------------------
362
363	call oasis_debug_enter(subname)
364
365	lsize = size(array)
366
367	call MPI_SEND(array,lsize,MPI_REAL8,pid,tag,comm,ierr)
368	if (present(string)) then
369	call oasis_mpi_chkerr(ierr,subName//trim(string))
370	else
371	call oasis_mpi_chkerr(ierr,subName)
372	endif
373
374	call oasis_debug_exit(subname)
375
376	END SUBROUTINE oasis_mpi_sendr3
377
378	!===============================================================================
379	!===============================================================================
380
381	!> Receive a scalar integer
382
383	SUBROUTINE oasis_mpi_recvi0(lvec,pid,tag,comm,string)
384
385	IMPLICIT none
386
387	!----- arguments ---
388	integer(ip_i4_p), intent(out):: lvec !< receive values
389	integer(ip_i4_p), intent(in) :: pid !< pid to recv from
390	integer(ip_i4_p), intent(in) :: tag !< mpi tag
391	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
392	character(*),optional,intent(in) :: string !< to identify caller
393
394	!----- local ---
395	character(*),parameter :: subname = '(oasis_mpi_recvi0)'
396	integer(ip_i4_p) :: lsize
397	integer(ip_i4_p) :: status(MPI_STATUS_SIZE) ! mpi status info
398	integer(ip_i4_p) :: ierr
399
400	!-------------------------------------------------------------------------------
401	! PURPOSE: Recv a vector of reals
402	!-------------------------------------------------------------------------------
403
404	call oasis_debug_enter(subname)
405
406	lsize = 1
407
408	call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr)
409	if (present(string)) then
410	call oasis_mpi_chkerr(ierr,subName//trim(string))
411	else
412	call oasis_mpi_chkerr(ierr,subName)
413	endif
414
415	call oasis_debug_exit(subname)
416
417	END SUBROUTINE oasis_mpi_recvi0
418
419	!===============================================================================
420	!===============================================================================
421
422	!> Receive an array of 1D integers
423
424	SUBROUTINE oasis_mpi_recvi1(lvec,pid,tag,comm,string)
425
426	IMPLICIT none
427
428	!----- arguments ---
429	integer(ip_i4_p), intent(out):: lvec(:) !< receive values
430	integer(ip_i4_p), intent(in) :: pid !< pid to recv from
431	integer(ip_i4_p), intent(in) :: tag !< mpi tag
432	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
433	character(*),optional,intent(in) :: string !< to identify caller
434
435	!----- local ---
436	character(*),parameter :: subname = '(oasis_mpi_recvi1)'
437	integer(ip_i4_p) :: lsize
438	integer(ip_i4_p) :: status(MPI_STATUS_SIZE) ! mpi status info
439	integer(ip_i4_p) :: ierr
440
441	!-------------------------------------------------------------------------------
442	! PURPOSE: Recv a vector of reals
443	!-------------------------------------------------------------------------------
444
445	call oasis_debug_enter(subname)
446
447	lsize = size(lvec)
448
449	call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr)
450	if (present(string)) then
451	call oasis_mpi_chkerr(ierr,subName//trim(string))
452	else
453	call oasis_mpi_chkerr(ierr,subName)
454	endif
455
456	call oasis_debug_exit(subname)
457
458	END SUBROUTINE oasis_mpi_recvi1
459
460	!===============================================================================
461	!===============================================================================
462
463	!> Receive a scalar double
464
465	SUBROUTINE oasis_mpi_recvr0(lvec,pid,tag,comm,string)
466
467	IMPLICIT none
468
469	!----- arguments ---
470	real(ip_double_p),intent(out):: lvec !< receive values
471	integer(ip_i4_p), intent(in) :: pid !< pid to recv from
472	integer(ip_i4_p), intent(in) :: tag !< mpi tag
473	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
474	character(*),optional,intent(in) :: string !< to identify caller
475
476	!----- local ---
477	character(*),parameter :: subname = '(oasis_mpi_recvr0)'
478	integer(ip_i4_p) :: lsize
479	integer(ip_i4_p) :: status(MPI_STATUS_SIZE) ! mpi status info
480	integer(ip_i4_p) :: ierr
481
482	!-------------------------------------------------------------------------------
483	! PURPOSE: Recv a vector of reals
484	!-------------------------------------------------------------------------------
485
486	call oasis_debug_enter(subname)
487
488	lsize = 1
489
490	call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr)
491	if (present(string)) then
492	call oasis_mpi_chkerr(ierr,subName//trim(string))
493	else
494	call oasis_mpi_chkerr(ierr,subName)
495	endif
496
497	call oasis_debug_exit(subname)
498
499	END SUBROUTINE oasis_mpi_recvr0
500
501	!===============================================================================
502	!===============================================================================
503
504	!> Receive an array of 1D doubles
505
506	SUBROUTINE oasis_mpi_recvr1(lvec,pid,tag,comm,string)
507
508	IMPLICIT none
509
510	!----- arguments ---
511	real(ip_double_p),intent(out):: lvec(:) !< receive values
512	integer(ip_i4_p), intent(in) :: pid !< pid to recv from
513	integer(ip_i4_p), intent(in) :: tag !< mpi tag
514	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
515	character(*),optional,intent(in) :: string !< to identify caller
516
517	!----- local ---
518	character(*),parameter :: subname = '(oasis_mpi_recvr1)'
519	integer(ip_i4_p) :: lsize
520	integer(ip_i4_p) :: status(MPI_STATUS_SIZE) ! mpi status info
521	integer(ip_i4_p) :: ierr
522
523	!-------------------------------------------------------------------------------
524	! PURPOSE: Recv a vector of reals
525	!-------------------------------------------------------------------------------
526
527	call oasis_debug_enter(subname)
528
529	lsize = size(lvec)
530
531	call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr)
532	if (present(string)) then
533	call oasis_mpi_chkerr(ierr,subName//trim(string))
534	else
535	call oasis_mpi_chkerr(ierr,subName)
536	endif
537
538	call oasis_debug_exit(subname)
539
540	END SUBROUTINE oasis_mpi_recvr1
541
542	!===============================================================================
543	!===============================================================================
544
545	!> Receive an array of 3D doubles
546
547	SUBROUTINE oasis_mpi_recvr3(array,pid,tag,comm,string)
548
549	IMPLICIT none
550
551	!----- arguments ---
552	real(ip_double_p),intent(out):: array(:,:,:) !< receive values
553	integer(ip_i4_p), intent(in) :: pid !< pid to recv from
554	integer(ip_i4_p), intent(in) :: tag !< mpi tag
555	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
556	character(*),optional,intent(in) :: string !< to identify caller
557
558	!----- local ---
559	character(*),parameter :: subname = '(oasis_mpi_recvr3)'
560	integer(ip_i4_p) :: lsize
561	integer(ip_i4_p) :: status(MPI_STATUS_SIZE) ! mpi status info
562	integer(ip_i4_p) :: ierr
563
564	!-------------------------------------------------------------------------------
565	! PURPOSE: Recv a vector of reals
566	!-------------------------------------------------------------------------------
567
568	call oasis_debug_enter(subname)
569
570	lsize = size(array)
571
572	call MPI_RECV(array,lsize,MPI_REAL8,pid,tag,comm,status,ierr)
573	if (present(string)) then
574	call oasis_mpi_chkerr(ierr,subName//trim(string))
575	else
576	call oasis_mpi_chkerr(ierr,subName)
577	endif
578
579	call oasis_debug_exit(subname)
580
581	END SUBROUTINE oasis_mpi_recvr3
582
583	!===============================================================================
584	!===============================================================================
585
586	!> Broadcast a scalar integer
587
588	SUBROUTINE oasis_mpi_bcasti0(vec,comm,string,pebcast)
589
590	IMPLICIT none
591
592	!----- arguments ---
593	integer(ip_i4_p), intent(inout):: vec !< values to broadcast
594	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
595	character(*),optional,intent(in) :: string !< to identify caller
596	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
597
598	!----- local ---
599	character(*),parameter :: subname = '(oasis_mpi_bcasti0)'
600	integer(ip_i4_p) :: ierr
601	integer(ip_i4_p) :: lsize
602	integer(ip_i4_p) :: lpebcast
603
604	!-------------------------------------------------------------------------------
605	! PURPOSE: Broadcast an integer
606	!-------------------------------------------------------------------------------
607
608	call oasis_debug_enter(subname)
609
610	lsize = 1
611	lpebcast = 0
612	if (present(pebcast)) lpebcast = pebcast
613
614	call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr)
615	if (present(string)) then
616	call oasis_mpi_chkerr(ierr,subName//trim(string))
617	else
618	call oasis_mpi_chkerr(ierr,subName)
619	endif
620
621	call oasis_debug_exit(subname)
622
623	END SUBROUTINE oasis_mpi_bcasti0
624
625	!===============================================================================
626	!===============================================================================
627
628	!> Broadcast a scalar logical
629
630	SUBROUTINE oasis_mpi_bcastl0(vec,comm,string,pebcast)
631
632	IMPLICIT none
633
634	!----- arguments ---
635	logical, intent(inout):: vec !< values to broadcast
636	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
637	character(*),optional,intent(in) :: string !< to identify caller
638	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
639
640	!----- local ---
641	character(*),parameter :: subname = '(oasis_mpi_bcastl0)'
642	integer(ip_i4_p) :: ierr
643	integer(ip_i4_p) :: lsize
644	integer(ip_i4_p) :: lpebcast
645
646	!-------------------------------------------------------------------------------
647	! PURPOSE: Broadcast a logical
648	!-------------------------------------------------------------------------------
649
650	call oasis_debug_enter(subname)
651
652	lsize = 1
653	lpebcast = 0
654	if (present(pebcast)) lpebcast = pebcast
655
656	call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr)
657	if (present(string)) then
658	call oasis_mpi_chkerr(ierr,subName//trim(string))
659	else
660	call oasis_mpi_chkerr(ierr,subName)
661	endif
662
663	call oasis_debug_exit(subname)
664
665	END SUBROUTINE oasis_mpi_bcastl0
666
667	!===============================================================================
668	!===============================================================================
669
670	!> Broadcast a character string
671
672	SUBROUTINE oasis_mpi_bcastc0(vec,comm,string,pebcast)
673
674	IMPLICIT none
675
676	!----- arguments ---
677	character(len=*), intent(inout):: vec !< values to broadcast
678	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
679	character(*),optional,intent(in) :: string !< to identify caller
680	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
681
682	!----- local ---
683	character(*),parameter :: subname = '(oasis_mpi_bcastc0)'
684	integer(ip_i4_p) :: ierr
685	integer(ip_i4_p) :: lsize
686	integer(ip_i4_p) :: lpebcast
687
688	!-------------------------------------------------------------------------------
689	! PURPOSE: Broadcast a character string
690	!-------------------------------------------------------------------------------
691
692	call oasis_debug_enter(subname)
693
694	lsize = len(vec)
695	lpebcast = 0
696	if (present(pebcast)) lpebcast = pebcast
697
698	call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr)
699	if (present(string)) then
700	call oasis_mpi_chkerr(ierr,subName//trim(string))
701	else
702	call oasis_mpi_chkerr(ierr,subName)
703	endif
704
705	call oasis_debug_exit(subname)
706
707	END SUBROUTINE oasis_mpi_bcastc0
708
709	!===============================================================================
710	!===============================================================================
711
712	!> Broadcast an array of 1D character strings
713
714	SUBROUTINE oasis_mpi_bcastc1(vec,comm,string,pebcast)
715
716	IMPLICIT none
717
718	!----- arguments ---
719	character(len=*), intent(inout):: vec(:) !< values to broadcast
720	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
721	character(*),optional,intent(in) :: string !< to identify caller
722	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
723
724	!----- local ---
725	character(*),parameter :: subname = '(oasis_mpi_bcastc1)'
726	integer(ip_i4_p) :: ierr
727	integer(ip_i4_p) :: lsize
728	integer(ip_i4_p) :: lpebcast
729
730	!-------------------------------------------------------------------------------
731	! PURPOSE: Broadcast a character string
732	!-------------------------------------------------------------------------------
733
734	call oasis_debug_enter(subname)
735
736	lsize = size(vec)*len(vec)
737	lpebcast = 0
738	if (present(pebcast)) lpebcast = pebcast
739
740	call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr)
741	if (present(string)) then
742	call oasis_mpi_chkerr(ierr,subName//trim(string))
743	else
744	call oasis_mpi_chkerr(ierr,subName)
745	endif
746
747	call oasis_debug_exit(subname)
748
749	END SUBROUTINE oasis_mpi_bcastc1
750
751	!===============================================================================
752	!===============================================================================
753
754	!> Broadcast a scalar double
755
756	SUBROUTINE oasis_mpi_bcastr0(vec,comm,string,pebcast)
757
758	IMPLICIT none
759
760	!----- arguments ---
761	real(ip_double_p), intent(inout):: vec !< values to broadcast
762	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
763	character(*),optional,intent(in) :: string !< to identify caller
764	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
765
766	!----- local ---
767	character(*),parameter :: subname = '(oasis_mpi_bcastr0)'
768	integer(ip_i4_p) :: ierr
769	integer(ip_i4_p) :: lsize
770	integer(ip_i4_p) :: lpebcast
771
772	!-------------------------------------------------------------------------------
773	! PURPOSE: Broadcast a real
774	!-------------------------------------------------------------------------------
775
776	call oasis_debug_enter(subname)
777
778	lsize = 1
779	lpebcast = 0
780	if (present(pebcast)) lpebcast = pebcast
781
782	call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr)
783	if (present(string)) then
784	call oasis_mpi_chkerr(ierr,subName//trim(string))
785	else
786	call oasis_mpi_chkerr(ierr,subName)
787	endif
788
789	call oasis_debug_exit(subname)
790
791	END SUBROUTINE oasis_mpi_bcastr0
792
793	!===============================================================================
794	!===============================================================================
795
796	!> Broadcast an array of 1D integers
797
798	SUBROUTINE oasis_mpi_bcasti1(vec,comm,string,pebcast)
799
800	IMPLICIT none
801
802	!----- arguments ---
803	integer(ip_i4_p), intent(inout):: vec(:) !< values to broadcast
804	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
805	character(*),optional,intent(in) :: string !< to identify caller
806	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
807
808	!----- local ---
809	character(*),parameter :: subname = '(oasis_mpi_bcasti1)'
810	integer(ip_i4_p) :: ierr
811	integer(ip_i4_p) :: lsize
812	integer(ip_i4_p) :: lpebcast
813
814	!-------------------------------------------------------------------------------
815	! PURPOSE: Broadcast a vector of integers
816	!-------------------------------------------------------------------------------
817
818	call oasis_debug_enter(subname)
819
820	lsize = size(vec)
821	lpebcast = 0
822	if (present(pebcast)) lpebcast = pebcast
823
824	call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr)
825	if (present(string)) then
826	call oasis_mpi_chkerr(ierr,subName//trim(string))
827	else
828	call oasis_mpi_chkerr(ierr,subName)
829	endif
830
831	call oasis_debug_exit(subname)
832
833	END SUBROUTINE oasis_mpi_bcasti1
834
835	!===============================================================================
836	!===============================================================================
837
838	!> Broadcast an array of 1D logicals
839
840	SUBROUTINE oasis_mpi_bcastl1(vec,comm,string,pebcast)
841
842	IMPLICIT none
843
844	!----- arguments ---
845	logical, intent(inout):: vec(:) !< values to broadcast
846	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
847	character(*),optional,intent(in) :: string !< to identify caller
848	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
849
850	!----- local ---
851	character(*),parameter :: subname = '(oasis_mpi_bcastl1)'
852	integer(ip_i4_p) :: ierr
853	integer(ip_i4_p) :: lsize
854	integer(ip_i4_p) :: lpebcast
855
856	!-------------------------------------------------------------------------------
857	! PURPOSE: Broadcast a logical
858	!-------------------------------------------------------------------------------
859
860	call oasis_debug_enter(subname)
861
862	lsize = size(vec)
863	lpebcast = 0
864	if (present(pebcast)) lpebcast = pebcast
865
866	call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr)
867	if (present(string)) then
868	call oasis_mpi_chkerr(ierr,subName//trim(string))
869	else
870	call oasis_mpi_chkerr(ierr,subName)
871	endif
872
873	call oasis_debug_exit(subname)
874
875	END SUBROUTINE oasis_mpi_bcastl1
876
877	!===============================================================================
878	!===============================================================================
879
880	!> Broadcast an array of 1D doubles
881
882	SUBROUTINE oasis_mpi_bcastr1(vec,comm,string,pebcast)
883
884	IMPLICIT none
885
886	!----- arguments ---
887	real(ip_double_p), intent(inout):: vec(:) !< values to broadcast
888	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
889	character(*),optional,intent(in) :: string !< to identify caller
890	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
891
892	!----- local ---
893	character(*),parameter :: subname = '(oasis_mpi_bcastr1)'
894	integer(ip_i4_p) :: ierr
895	integer(ip_i4_p) :: lsize
896	integer(ip_i4_p) :: lpebcast
897
898	!-------------------------------------------------------------------------------
899	! PURPOSE: Broadcast a vector of reals
900	!-------------------------------------------------------------------------------
901
902	call oasis_debug_enter(subname)
903
904	lsize = size(vec)
905	lpebcast = 0
906	if (present(pebcast)) lpebcast = pebcast
907
908	call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr)
909	if (present(string)) then
910	call oasis_mpi_chkerr(ierr,subName//trim(string))
911	else
912	call oasis_mpi_chkerr(ierr,subName)
913	endif
914
915	call oasis_debug_exit(subname)
916
917	END SUBROUTINE oasis_mpi_bcastr1
918
919	!===============================================================================
920	!===============================================================================
921
922	!> Broadcast an array of 2D doubles
923
924	SUBROUTINE oasis_mpi_bcastr2(arr,comm,string,pebcast)
925
926	IMPLICIT none
927
928	!----- arguments -----
929	real(ip_double_p), intent(inout):: arr(:,:) !< values to broadcast
930	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
931	character(*),optional,intent(in) :: string !< to identify caller
932	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
933
934	!----- local -----
935	integer(ip_i4_p) :: ierr
936	integer(ip_i4_p) :: lsize
937	integer(ip_i4_p) :: lpebcast
938
939	!----- formats -----
940	character(*),parameter :: subname = '(oasis_mpi_bcastr2)'
941
942	!-------------------------------------------------------------------------------
943	! PURPOSE: Broadcast a 2d array of reals
944	!-------------------------------------------------------------------------------
945
946	call oasis_debug_enter(subname)
947
948	lsize = size(arr)
949	lpebcast = 0
950	if (present(pebcast)) lpebcast = pebcast
951
952	call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr)
953	if (present(string)) then
954	call oasis_mpi_chkerr(ierr,subName//trim(string))
955	else
956	call oasis_mpi_chkerr(ierr,subName)
957	endif
958
959	call oasis_debug_exit(subname)
960
961	END SUBROUTINE oasis_mpi_bcastr2
962
963	!===============================================================================
964	!===============================================================================
965
966	!> Broadcast an array of 2D integers
967
968	SUBROUTINE oasis_mpi_bcasti2(arr,comm,string,pebcast)
969
970	IMPLICIT none
971
972	!----- arguments -----
973	integer, intent(inout):: arr(:,:) !< values to broadcast
974	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
975	character(*),optional,intent(in) :: string !< to identify caller
976	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
977
978	!----- local -----
979	integer(ip_i4_p) :: ierr
980	integer(ip_i4_p) :: lsize
981	integer(ip_i4_p) :: lpebcast
982
983	!----- formats -----
984	character(*),parameter :: subname = '(oasis_mpi_bcasti2)'
985
986	!-------------------------------------------------------------------------------
987	! PURPOSE: Broadcast a 2d array of integers
988	!-------------------------------------------------------------------------------
989
990	call oasis_debug_enter(subname)
991
992	lsize = size(arr)
993	lpebcast = 0
994	if (present(pebcast)) lpebcast = pebcast
995
996	call MPI_BCAST(arr,lsize,MPI_INTEGER,lpebcast,comm,ierr)
997	if (present(string)) then
998	call oasis_mpi_chkerr(ierr,subName//trim(string))
999	else
1000	call oasis_mpi_chkerr(ierr,subName)
1001	endif
1002
1003	call oasis_debug_exit(subname)
1004
1005	END SUBROUTINE oasis_mpi_bcasti2
1006
1007	!===============================================================================
1008	!===============================================================================
1009
1010	!> Broadcast an array of 3D doubles
1011
1012	SUBROUTINE oasis_mpi_bcastr3(arr,comm,string,pebcast)
1013
1014	IMPLICIT none
1015
1016	!----- arguments -----
1017	real(ip_double_p), intent(inout):: arr(:,:,:) !< values to broadcast
1018	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1019	character(*),optional,intent(in) :: string !< to identify caller
1020	integer(ip_i4_p), optional, intent(in) :: pebcast !< bcast pe, default is task 0
1021
1022	!----- local -----
1023	integer(ip_i4_p) :: ierr
1024	integer(ip_i4_p) :: lsize
1025	integer(ip_i4_p) :: lpebcast
1026
1027	!----- formats -----
1028	character(*),parameter :: subname = '(oasis_mpi_bcastr3)'
1029
1030	!-------------------------------------------------------------------------------
1031	! PURPOSE: Broadcast a 3d array of reals
1032	!-------------------------------------------------------------------------------
1033
1034	call oasis_debug_enter(subname)
1035
1036	lsize = size(arr)
1037	lpebcast = 0
1038	if (present(pebcast)) lpebcast = pebcast
1039
1040	call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr)
1041	if (present(string)) then
1042	call oasis_mpi_chkerr(ierr,subName//trim(string))
1043	else
1044	call oasis_mpi_chkerr(ierr,subName)
1045	endif
1046
1047	call oasis_debug_exit(subname)
1048
1049	END SUBROUTINE oasis_mpi_bcastr3
1050
1051	!===============================================================================
1052	!===============================================================================
1053
1054	!> Initialize variables for oasis_mpi_gatherv and oasis_mpi_scatterv
1055
1056	!> This method initializes glob1DArr, globSize, and displs for use
1057	!> in the oasis_mpi_gatherv and oasis_mpi_scatterv routines. locArr is the
1058	!> distributed array to gather from or scatter to.
1059
1060	SUBROUTINE oasis_mpi_gathScatvInitr1(comm, rootid, locArr, glob1DArr, globSize, &
1061	displs, string )
1062
1063	IMPLICIT none
1064
1065	!----- arguments -----
1066	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1067	integer(ip_i4_p), intent(in) :: rootid !< MPI task to gather/scatter on
1068	real(ip_double_p),intent(in) :: locArr(:) !< Local array of distributed data
1069	real(ip_double_p),pointer :: glob1DArr(:) !< Global 1D array of gathered data
1070	integer(ip_i4_p), pointer :: globSize(:) !< Size of each distributed piece
1071	integer(ip_i4_p), pointer :: displs(:) !< Displacements for receive
1072	character(*),optional,intent(in):: string !< to identify caller
1073
1074	!----- local -----
1075	integer(ip_i4_p) :: npes ! Number of MPI tasks
1076	integer(ip_i4_p) :: locSize ! Size of local distributed data
1077	integer(ip_i4_p), pointer :: sendSize(:) ! Size to send for initial gather
1078	integer(ip_i4_p) :: i ! Index
1079	integer(ip_i4_p) :: rank ! Rank of this MPI task
1080	integer(ip_i4_p) :: nSize ! Maximum size to send
1081	integer(ip_i4_p) :: ierr ! Error code
1082	integer(ip_i4_p) :: nSiz1D ! Size of 1D global array
1083	integer(ip_i4_p) :: maxSize ! Maximum size
1084
1085	!----- formats -----
1086	character(*),parameter :: subname = '(oasis_mpi_gathScatvInitr1)'
1087
1088	!-------------------------------------------------------------------------------
1089	! PURPOSE: Setup arrays for a gatherv/scatterv operation
1090	!-------------------------------------------------------------------------------
1091
1092	call oasis_debug_enter(subname)
1093
1094	locSize = size(locarr)
1095	call oasis_mpi_commsize( comm, npes )
1096	call oasis_mpi_commrank( comm, rank )
1097	allocate( globSize(npes) )
1098	!
1099	! --- Gather the send global sizes from each MPI task -----------------------
1100	!
1101	allocate( sendSize(npes) )
1102	sendSize(:) = 1
1103	globSize(:) = 1
1104	call MPI_GATHER( locSize, 1, MPI_INTEGER, globSize, sendSize, &
1105	MPI_INTEGER, rootid, comm, ierr )
1106	if (present(string)) then
1107	call oasis_mpi_chkerr(ierr,subName//trim(string))
1108	else
1109	call oasis_mpi_chkerr(ierr,subName)
1110	endif
1111	deallocate( sendSize )
1112	!
1113	! --- Prepare the displacement and allocate arrays -------------------------
1114	!
1115	allocate( displs(npes) )
1116	displs(1) = 0
1117	if ( rootid /= rank )then
1118	maxSize = 1
1119	globSize = 1
1120	else
1121	maxSize = maxval(globSize)
1122	end if
1123	nsiz1D = min(maxSize,globSize(1))
1124	do i = 2, npes
1125	nSize = min(maxSize,globSize(i-1))
1126	displs(i) = displs(i-1) + nSize
1127	nsiz1D = nsiz1D + min(maxSize,globSize(i))
1128	end do
1129	allocate( glob1DArr(nsiz1D) )
1130	!----- Do some error checking for the root task arrays computed ----
1131	if ( rootid == rank )then
1132	if ( nsiz1D /= sum(globSize) ) &
1133	call oasis_mpi_abort( subName//" : Error, size of global array not right" )
1134	if ( any(displs < 0) .or. any(displs >= nsiz1D) ) &
1135	call oasis_mpi_abort( subName//" : Error, displacement array not right" )
1136	if ( (displs(npes)+globSize(npes)) /= nsiz1D ) &
1137	call oasis_mpi_abort( subName//" : Error, displacement array values too big" )
1138	end if
1139
1140	call oasis_debug_exit(subname)
1141
1142	END SUBROUTINE oasis_mpi_gathScatvInitr1
1143
1144	!===============================================================================
1145	!===============================================================================
1146
1147	!> Gather a vector of distributed data to a rootid
1148
1149	!> This method passes in glob1DArr, globSize, and displs computed
1150	!> in the oasis_mpi_gathscatvinit routine and uses that information to
1151	!> gather the locArr into the glob1Darr on processor rootid in communicator
1152	!> comm.
1153
1154	SUBROUTINE oasis_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, &
1155	comm, string )
1156
1157	IMPLICIT none
1158
1159	!----- arguments -----
1160	real(ip_double_p),intent(in) :: locArr(:) !< Local array
1161	real(ip_double_p),intent(inout) :: glob1DArr(:) !< Global 1D array to receive in on
1162	integer(ip_i4_p), intent(in) :: locSize !< Number to send from this PE
1163	integer(ip_i4_p), intent(in) :: globSize(:) !< Number to receive from each PE
1164	integer(ip_i4_p), intent(in) :: displs(:) !< Displacements for receives
1165	integer(ip_i4_p), intent(in) :: rootid !< MPI task to gather on
1166	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1167	character(*),optional,intent(in):: string !< to identify caller
1168
1169	!----- local -----
1170	integer(ip_i4_p) :: ierr ! Error code
1171
1172	!----- formats -----
1173	character(*),parameter :: subname = '(oasis_mpi_gathervr1)'
1174
1175	!-------------------------------------------------------------------------------
1176	! PURPOSE: Gather a 1D array of reals
1177	!-------------------------------------------------------------------------------
1178
1179	call oasis_debug_enter(subname)
1180
1181	call MPI_GATHERV( locarr, locSize, MPI_REAL8, glob1Darr, globSize, displs, &
1182	MPI_REAL8, rootid, comm, ierr )
1183	if (present(string)) then
1184	call oasis_mpi_chkerr(ierr,subName//trim(string))
1185	else
1186	call oasis_mpi_chkerr(ierr,subName)
1187	endif
1188
1189	call oasis_debug_exit(subname)
1190
1191	END SUBROUTINE oasis_mpi_gathervr1
1192
1193	!===============================================================================
1194	!===============================================================================
1195
1196	!> Scatter a vector of global data from a rootid
1197
1198	!> This method passes in glob1DArr, globSize, and displs computed
1199	!> in the oasis_mpi_gathscatvinit routine and uses that information to
1200	!> scatter glob1Darr on processor rootid in communicator comm to locarr
1201	!> on other processors.
1202
1203	SUBROUTINE oasis_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, &
1204	comm, string )
1205
1206	IMPLICIT none
1207
1208	!----- arguments -----
1209	real(ip_double_p),intent(out) :: locarr(:) !< Local array
1210	real(ip_double_p),intent(in) :: glob1Darr(:) !< Global 1D array to send from
1211	integer(ip_i4_p), intent(in) :: locSize !< Number to receive this PE
1212	integer(ip_i4_p), intent(in) :: globSize(:) !< Number to send to each PE
1213	integer(ip_i4_p), intent(in) :: displs(:) !< Displacements for send
1214	integer(ip_i4_p), intent(in) :: rootid !< MPI task to scatter on
1215	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1216	character(*),optional,intent(in):: string !< to identify caller
1217
1218	!----- local -----
1219	integer(ip_i4_p) :: ierr ! Error code
1220
1221	!----- formats -----
1222	character(*),parameter :: subname = '(oasis_mpi_scattervr1)'
1223
1224	!-------------------------------------------------------------------------------
1225	! PURPOSE: Scatter a 1D array of reals
1226	!-------------------------------------------------------------------------------
1227
1228	call oasis_debug_enter(subname)
1229
1230	call MPI_SCATTERV( glob1Darr, globSize, displs, MPI_REAL8, locarr, locSize, &
1231	MPI_REAL8, rootid, comm, ierr )
1232	if (present(string)) then
1233	call oasis_mpi_chkerr(ierr,subName//trim(string))
1234	else
1235	call oasis_mpi_chkerr(ierr,subName)
1236	endif
1237
1238	call oasis_debug_exit(subname)
1239
1240	END SUBROUTINE oasis_mpi_scattervr1
1241
1242
1243	!===============================================================================
1244	!===============================================================================
1245
1246	!> Compute a global Sum for a scalar integer
1247
1248	SUBROUTINE oasis_mpi_sumi0(lvec,gvec,comm,string,all)
1249
1250	IMPLICIT none
1251
1252	!----- arguments ---
1253	integer(ip_i4_p), intent(in) :: lvec !< local values
1254	integer(ip_i4_p), intent(out):: gvec !< global values
1255	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1256	character(*),optional,intent(in) :: string !< to identify caller
1257	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1258
1259	!----- local ---
1260	character(*),parameter :: subname = '(oasis_mpi_sumi0)'
1261	logical :: lall
1262	character(len=256) :: lstring
1263	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1264	integer(ip_i4_p) :: lsize
1265	integer(ip_i4_p) :: gsize
1266	integer(ip_i4_p) :: ierr
1267
1268	!-------------------------------------------------------------------------------
1269	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1270	! already computed
1271	!-------------------------------------------------------------------------------
1272
1273	call oasis_debug_enter(subname)
1274
1275	reduce_type = MPI_SUM
1276	if (present(all)) then
1277	lall = all
1278	else
1279	lall = .false.
1280	endif
1281	if (present(string)) then
1282	lstring = trim(subName)//":"//trim(string)
1283	else
1284	lstring = trim(subName)
1285	endif
1286
1287	lsize = 1
1288	gsize = 1
1289
1290	if (lsize /= gsize) then
1291	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1292	endif
1293
1294	if (lall) then
1295	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
1296	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1297	else
1298	call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
1299	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1300	endif
1301
1302	call oasis_debug_exit(subname)
1303
1304	END SUBROUTINE oasis_mpi_sumi0
1305
1306	!===============================================================================
1307	!===============================================================================
1308
1309	!> Compute a 1D array of global sums for an array of 1D integers
1310
1311	!> This sums an array of local integers to an array of summed integers.
1312	!> This does not reduce the array to a scalar.
1313
1314	SUBROUTINE oasis_mpi_sumi1(lvec,gvec,comm,string,all)
1315
1316	IMPLICIT none
1317
1318	!----- arguments ---
1319	integer(ip_i4_p), intent(in) :: lvec(:) !< local values
1320	integer(ip_i4_p), intent(out):: gvec(:) !< global values
1321	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1322	character(*),optional,intent(in) :: string !< to identify caller
1323	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1324
1325	!----- local ---
1326	character(*),parameter :: subname = '(oasis_mpi_sumi1)'
1327	logical :: lall
1328	character(len=256) :: lstring
1329	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1330	integer(ip_i4_p) :: lsize
1331	integer(ip_i4_p) :: gsize
1332	integer(ip_i4_p) :: ierr
1333
1334	!-------------------------------------------------------------------------------
1335	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1336	! already computed
1337	!-------------------------------------------------------------------------------
1338
1339	call oasis_debug_enter(subname)
1340
1341	reduce_type = MPI_SUM
1342	if (present(all)) then
1343	lall = all
1344	else
1345	lall = .false.
1346	endif
1347	if (present(string)) then
1348	lstring = trim(subName)//":"//trim(string)
1349	else
1350	lstring = trim(subName)
1351	endif
1352
1353	lsize = size(lvec)
1354	gsize = size(gvec)
1355
1356	if (lsize /= gsize) then
1357	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1358	endif
1359
1360	if (lall) then
1361	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
1362	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1363	else
1364	call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
1365	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1366	endif
1367
1368	call oasis_debug_exit(subname)
1369
1370	END SUBROUTINE oasis_mpi_sumi1
1371
1372	!===============================================================================
1373	!===============================================================================
1374
1375	!> Compute a global sum for a scalar 8 byte integer
1376
1377	SUBROUTINE oasis_mpi_sumb0(lvec,gvec,comm,string,all)
1378
1379	IMPLICIT none
1380
1381	!----- arguments ---
1382	integer(ip_i8_p), intent(in) :: lvec !< local values
1383	integer(ip_i8_p), intent(out):: gvec !< global values
1384	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1385	character(*),optional,intent(in) :: string !< to identify caller
1386	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1387
1388	!----- local ---
1389	character(*),parameter :: subname = '(oasis_mpi_sumb0)'
1390	logical :: lall
1391	character(len=256) :: lstring
1392	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1393	integer(ip_i4_p) :: lsize
1394	integer(ip_i4_p) :: gsize
1395	integer(ip_i4_p) :: ierr
1396
1397	!-------------------------------------------------------------------------------
1398	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1399	! already computed
1400	!-------------------------------------------------------------------------------
1401
1402	call oasis_debug_enter(subname)
1403
1404	reduce_type = MPI_SUM
1405	if (present(all)) then
1406	lall = all
1407	else
1408	lall = .false.
1409	endif
1410	if (present(string)) then
1411	lstring = trim(subName)//":"//trim(string)
1412	else
1413	lstring = trim(subName)
1414	endif
1415
1416	lsize = 1
1417	gsize = 1
1418
1419	if (lsize /= gsize) then
1420	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1421	endif
1422
1423	if (lall) then
1424	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr)
1425	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1426	else
1427	call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr)
1428	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1429	endif
1430
1431	call oasis_debug_exit(subname)
1432
1433	END SUBROUTINE oasis_mpi_sumb0
1434
1435	!===============================================================================
1436	!===============================================================================
1437
1438	!> Compute a 1D array of global sums for an array of 1D 8 byte integers
1439
1440	!> This sums an array of local integers to an array of summed integers.
1441	!> This does not reduce the array to a scalar.
1442
1443	SUBROUTINE oasis_mpi_sumb1(lvec,gvec,comm,string,all)
1444
1445	IMPLICIT none
1446
1447	!----- arguments ---
1448	integer(ip_i8_p), intent(in) :: lvec(:) !< local values
1449	integer(ip_i8_p), intent(out):: gvec(:) !< global values
1450	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1451	character(*),optional,intent(in) :: string !< to identify caller
1452	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1453
1454	!----- local ---
1455	character(*),parameter :: subname = '(oasis_mpi_sumb1)'
1456	logical :: lall
1457	character(len=256) :: lstring
1458	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1459	integer(ip_i4_p) :: lsize
1460	integer(ip_i4_p) :: gsize
1461	integer(ip_i4_p) :: ierr
1462
1463	!-------------------------------------------------------------------------------
1464	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1465	! already computed
1466	!-------------------------------------------------------------------------------
1467
1468	call oasis_debug_enter(subname)
1469
1470	reduce_type = MPI_SUM
1471	if (present(all)) then
1472	lall = all
1473	else
1474	lall = .false.
1475	endif
1476	if (present(string)) then
1477	lstring = trim(subName)//":"//trim(string)
1478	else
1479	lstring = trim(subName)
1480	endif
1481
1482	lsize = size(lvec)
1483	gsize = size(gvec)
1484
1485	if (lsize /= gsize) then
1486	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1487	endif
1488
1489	if (lall) then
1490	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr)
1491	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1492	else
1493	call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr)
1494	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1495	endif
1496
1497	call oasis_debug_exit(subname)
1498
1499	END SUBROUTINE oasis_mpi_sumb1
1500
1501	!===============================================================================
1502	!===============================================================================
1503
1504	!> Compute a global sum for a scalar double
1505
1506	SUBROUTINE oasis_mpi_sumr0(lvec,gvec,comm,string,all)
1507
1508	IMPLICIT none
1509
1510	!----- arguments ---
1511	real(ip_double_p), intent(in) :: lvec !< local values
1512	real(ip_double_p), intent(out):: gvec !< global values
1513	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1514	character(*),optional,intent(in) :: string !< to identify caller
1515	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1516
1517	!----- local ---
1518	character(*),parameter :: subname = '(oasis_mpi_sumr0)'
1519	logical :: lall
1520	character(len=256) :: lstring
1521	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1522	integer(ip_i4_p) :: lsize
1523	integer(ip_i4_p) :: gsize
1524	integer(ip_i4_p) :: ierr
1525
1526	!-------------------------------------------------------------------------------
1527	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1528	! already computed
1529	!-------------------------------------------------------------------------------
1530
1531	call oasis_debug_enter(subname)
1532
1533	reduce_type = MPI_SUM
1534	if (present(all)) then
1535	lall = all
1536	else
1537	lall = .false.
1538	endif
1539	if (present(string)) then
1540	lstring = trim(subName)//":"//trim(string)
1541	else
1542	lstring = trim(subName)
1543	endif
1544
1545	lsize = 1
1546	gsize = 1
1547
1548	if (lsize /= gsize) then
1549	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1550	endif
1551
1552	if (lall) then
1553	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
1554	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1555	else
1556	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
1557	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1558	endif
1559
1560	call oasis_debug_exit(subname)
1561
1562	END SUBROUTINE oasis_mpi_sumr0
1563
1564	!===============================================================================
1565	!===============================================================================
1566
1567	!> Compute a 1D array of global sums for an array of 1D doubles
1568
1569	!> This sums an array of local doubles to an array of summed doubles.
1570	!> This does not reduce the array to a scalar.
1571
1572	SUBROUTINE oasis_mpi_sumr1(lvec,gvec,comm,string,all)
1573
1574	IMPLICIT none
1575
1576	!----- arguments ---
1577	real(ip_double_p), intent(in) :: lvec(:) !< local values
1578	real(ip_double_p), intent(out):: gvec(:) !< global values
1579	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1580	character(*),optional,intent(in) :: string !< to identify caller
1581	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1582
1583	!----- local ---
1584	character(*),parameter :: subname = '(oasis_mpi_sumr1)'
1585	logical :: lall
1586	character(len=256) :: lstring
1587	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1588	integer(ip_i4_p) :: lsize
1589	integer(ip_i4_p) :: gsize
1590	integer(ip_i4_p) :: ierr
1591
1592	!-------------------------------------------------------------------------------
1593	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1594	! already computed
1595	!-------------------------------------------------------------------------------
1596
1597	call oasis_debug_enter(subname)
1598
1599	reduce_type = MPI_SUM
1600	if (present(all)) then
1601	lall = all
1602	else
1603	lall = .false.
1604	endif
1605	if (present(string)) then
1606	lstring = trim(subName)//":"//trim(string)
1607	else
1608	lstring = trim(subName)
1609	endif
1610
1611	lsize = size(lvec)
1612	gsize = size(gvec)
1613
1614	if (lsize /= gsize) then
1615	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1616	endif
1617
1618	if (lall) then
1619	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
1620	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1621	else
1622	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
1623	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1624	endif
1625
1626	call oasis_debug_exit(subname)
1627
1628	END SUBROUTINE oasis_mpi_sumr1
1629
1630	!===============================================================================
1631	!===============================================================================
1632
1633	!> Compute a 2D array of global sums for an array of 2D doubles
1634
1635	!> This sums an array of local doubles to an array of summed doubles.
1636	!> This does not reduce the array to a scalar.
1637
1638	SUBROUTINE oasis_mpi_sumr2(lvec,gvec,comm,string,all)
1639
1640	IMPLICIT none
1641
1642	!----- arguments ---
1643	real(ip_double_p), intent(in) :: lvec(:,:)!< local values
1644	real(ip_double_p), intent(out):: gvec(:,:)!< global values
1645	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1646	character(*),optional,intent(in) :: string !< to identify caller
1647	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1648
1649	!----- local ---
1650	character(*),parameter :: subname = '(oasis_mpi_sumr2)'
1651	logical :: lall
1652	character(len=256) :: lstring
1653	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1654	integer(ip_i4_p) :: lsize
1655	integer(ip_i4_p) :: gsize
1656	integer(ip_i4_p) :: ierr
1657
1658	!-------------------------------------------------------------------------------
1659	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1660	! already computed
1661	!-------------------------------------------------------------------------------
1662
1663	call oasis_debug_enter(subname)
1664
1665	reduce_type = MPI_SUM
1666	if (present(all)) then
1667	lall = all
1668	else
1669	lall = .false.
1670	endif
1671	if (present(string)) then
1672	lstring = trim(subName)//":"//trim(string)
1673	else
1674	lstring = trim(subName)
1675	endif
1676
1677	lsize = size(lvec)
1678	gsize = size(gvec)
1679
1680	if (lsize /= gsize) then
1681	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1682	endif
1683
1684	if (lall) then
1685	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
1686	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1687	else
1688	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
1689	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1690	endif
1691
1692	call oasis_debug_exit(subname)
1693
1694	END SUBROUTINE oasis_mpi_sumr2
1695
1696	!===============================================================================
1697	!===============================================================================
1698
1699	!> Compute a 3D array of global sums for an array of 3D doubles
1700
1701	!> This sums an array of local doubles to an array of summed doubles.
1702	!> This does not reduce the array to a scalar.
1703
1704	SUBROUTINE oasis_mpi_sumr3(lvec,gvec,comm,string,all)
1705
1706	IMPLICIT none
1707
1708	!----- arguments ---
1709	real(ip_double_p), intent(in) :: lvec(:,:,:) !< local values
1710	real(ip_double_p), intent(out):: gvec(:,:,:) !< global values
1711	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1712	character(*),optional,intent(in) :: string !< to identify caller
1713	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1714
1715	!----- local ---
1716	character(*),parameter :: subname = '(oasis_mpi_sumr3)'
1717	logical :: lall
1718	character(len=256) :: lstring
1719	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1720	integer(ip_i4_p) :: lsize
1721	integer(ip_i4_p) :: gsize
1722	integer(ip_i4_p) :: ierr
1723
1724	!-------------------------------------------------------------------------------
1725	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1726	! already computed
1727	!-------------------------------------------------------------------------------
1728
1729	call oasis_debug_enter(subname)
1730
1731	reduce_type = MPI_SUM
1732	if (present(all)) then
1733	lall = all
1734	else
1735	lall = .false.
1736	endif
1737	if (present(string)) then
1738	lstring = trim(subName)//":"//trim(string)
1739	else
1740	lstring = trim(subName)
1741	endif
1742
1743	lsize = size(lvec)
1744	gsize = size(gvec)
1745
1746	if (lsize /= gsize) then
1747	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1748	endif
1749
1750	if (lall) then
1751	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
1752	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1753	else
1754	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
1755	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1756	endif
1757
1758	call oasis_debug_exit(subname)
1759
1760	END SUBROUTINE oasis_mpi_sumr3
1761
1762	!===============================================================================
1763
1764	#ifndef __NO_16BYTE_REALS
1765	!===============================================================================
1766
1767	!> Compute a global sum for a scalar quad
1768
1769	SUBROUTINE oasis_mpi_sumq0(lvec,gvec,comm,string,all)
1770
1771	IMPLICIT none
1772
1773	!----- arguments ---
1774	real(ip_quad_p), intent(in) :: lvec !< local values
1775	real(ip_quad_p), intent(out):: gvec !< global values
1776	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1777	character(*),optional,intent(in) :: string !< to identify caller
1778	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1779
1780	!----- local ---
1781	character(*),parameter :: subname = '(oasis_mpi_sumq0)'
1782	logical :: lall
1783	character(len=256) :: lstring
1784	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1785	integer(ip_i4_p) :: lsize
1786	integer(ip_i4_p) :: gsize
1787	integer(ip_i4_p) :: ierr
1788
1789	!-------------------------------------------------------------------------------
1790	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1791	! already computed
1792	!-------------------------------------------------------------------------------
1793
1794	call oasis_debug_enter(subname)
1795
1796	reduce_type = MPI_SUM
1797	if (present(all)) then
1798	lall = all
1799	else
1800	lall = .false.
1801	endif
1802	if (present(string)) then
1803	lstring = trim(subName)//":"//trim(string)
1804	else
1805	lstring = trim(subName)
1806	endif
1807
1808	lsize = 1
1809	gsize = 1
1810
1811	if (lsize /= gsize) then
1812	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1813	endif
1814
1815	if (lall) then
1816	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL16,reduce_type,comm,ierr)
1817	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1818	else
1819	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL16,reduce_type,0,comm,ierr)
1820	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1821	endif
1822
1823	call oasis_debug_exit(subname)
1824
1825	END SUBROUTINE oasis_mpi_sumq0
1826
1827	!===============================================================================
1828	!===============================================================================
1829
1830	!> Compute a 1D array of global sums for an array of 1D quads
1831
1832	!> This sums an array of local quads to an array of summed quads.
1833	!> This does not reduce the array to a scalar.
1834
1835	SUBROUTINE oasis_mpi_sumq1(lvec,gvec,comm,string,all)
1836
1837	IMPLICIT none
1838
1839	!----- arguments ---
1840	real(ip_quad_p), intent(in) :: lvec(:) !< local values
1841	real(ip_quad_p), intent(out):: gvec(:) !< global values
1842	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1843	character(*),optional,intent(in) :: string !< to identify caller
1844	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1845
1846	!----- local ---
1847	character(*),parameter :: subname = '(oasis_mpi_sumq1)'
1848	logical :: lall
1849	character(len=256) :: lstring
1850	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1851	integer(ip_i4_p) :: lsize
1852	integer(ip_i4_p) :: gsize
1853	integer(ip_i4_p) :: ierr
1854
1855	!-------------------------------------------------------------------------------
1856	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1857	! already computed
1858	!-------------------------------------------------------------------------------
1859
1860	call oasis_debug_enter(subname)
1861
1862	reduce_type = MPI_SUM
1863	if (present(all)) then
1864	lall = all
1865	else
1866	lall = .false.
1867	endif
1868	if (present(string)) then
1869	lstring = trim(subName)//":"//trim(string)
1870	else
1871	lstring = trim(subName)
1872	endif
1873
1874	lsize = size(lvec)
1875	gsize = size(gvec)
1876
1877	if (lsize /= gsize) then
1878	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1879	endif
1880
1881	if (lall) then
1882	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL16,reduce_type,comm,ierr)
1883	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1884	else
1885	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL16,reduce_type,0,comm,ierr)
1886	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1887	endif
1888
1889	call oasis_debug_exit(subname)
1890
1891	END SUBROUTINE oasis_mpi_sumq1
1892
1893	!===============================================================================
1894	!===============================================================================
1895
1896	!> Compute a 2D array of global sums for an array of 2D quads
1897
1898	!> This sums an array of local quads to an array of summed quads.
1899	!> This does not reduce the array to a scalar.
1900
1901	SUBROUTINE oasis_mpi_sumq2(lvec,gvec,comm,string,all)
1902
1903	IMPLICIT none
1904
1905	!----- arguments ---
1906	real(ip_quad_p), intent(in) :: lvec(:,:)!< local values
1907	real(ip_quad_p), intent(out):: gvec(:,:)!< global values
1908	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1909	character(*),optional,intent(in) :: string !< to identify caller
1910	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1911
1912	!----- local ---
1913	character(*),parameter :: subname = '(oasis_mpi_sumq2)'
1914	logical :: lall
1915	character(len=256) :: lstring
1916	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1917	integer(ip_i4_p) :: lsize
1918	integer(ip_i4_p) :: gsize
1919	integer(ip_i4_p) :: ierr
1920
1921	!-------------------------------------------------------------------------------
1922	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1923	! already computed
1924	!-------------------------------------------------------------------------------
1925
1926	call oasis_debug_enter(subname)
1927
1928	reduce_type = MPI_SUM
1929	if (present(all)) then
1930	lall = all
1931	else
1932	lall = .false.
1933	endif
1934	if (present(string)) then
1935	lstring = trim(subName)//":"//trim(string)
1936	else
1937	lstring = trim(subName)
1938	endif
1939
1940	lsize = size(lvec)
1941	gsize = size(gvec)
1942
1943	if (lsize /= gsize) then
1944	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
1945	endif
1946
1947	if (lall) then
1948	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL16,reduce_type,comm,ierr)
1949	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
1950	else
1951	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL16,reduce_type,0,comm,ierr)
1952	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
1953	endif
1954
1955	call oasis_debug_exit(subname)
1956
1957	END SUBROUTINE oasis_mpi_sumq2
1958
1959	!===============================================================================
1960	!===============================================================================
1961
1962	!> Compute a 3D array of global sums for an array of 3D quads
1963
1964	!> This sums an array of local quads to an array of summed quads.
1965	!> This does not reduce the array to a scalar.
1966
1967	SUBROUTINE oasis_mpi_sumq3(lvec,gvec,comm,string,all)
1968
1969	IMPLICIT none
1970
1971	!----- arguments ---
1972	real(ip_quad_p), intent(in) :: lvec(:,:,:) !< local values
1973	real(ip_quad_p), intent(out):: gvec(:,:,:) !< global values
1974	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
1975	character(*),optional,intent(in) :: string !< to identify caller
1976	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
1977
1978	!----- local ---
1979	character(*),parameter :: subname = '(oasis_mpi_sumq3)'
1980	logical :: lall
1981	character(len=256) :: lstring
1982	integer(ip_i4_p) :: reduce_type ! mpi reduction type
1983	integer(ip_i4_p) :: lsize
1984	integer(ip_i4_p) :: gsize
1985	integer(ip_i4_p) :: ierr
1986
1987	!-------------------------------------------------------------------------------
1988	! PURPOSE: Finds sum of a distributed vector of values, assume local sum
1989	! already computed
1990	!-------------------------------------------------------------------------------
1991
1992	call oasis_debug_enter(subname)
1993
1994	reduce_type = MPI_SUM
1995	if (present(all)) then
1996	lall = all
1997	else
1998	lall = .false.
1999	endif
2000	if (present(string)) then
2001	lstring = trim(subName)//":"//trim(string)
2002	else
2003	lstring = trim(subName)
2004	endif
2005
2006	lsize = size(lvec)
2007	gsize = size(gvec)
2008
2009	if (lsize /= gsize) then
2010	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2011	endif
2012
2013	if (lall) then
2014	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL16,reduce_type,comm,ierr)
2015	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2016	else
2017	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL16,reduce_type,0,comm,ierr)
2018	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2019	endif
2020
2021	call oasis_debug_exit(subname)
2022
2023	END SUBROUTINE oasis_mpi_sumq3
2024
2025	!===============================================================================
2026	! __NO_16BYTE_REALS
2027	#endif
2028	!===============================================================================
2029
2030	!> Compute a global minimum for a scalar integer
2031
2032	SUBROUTINE oasis_mpi_mini0(lvec,gvec,comm,string,all)
2033
2034	IMPLICIT none
2035
2036	!----- arguments ---
2037	integer(ip_i4_p), intent(in) :: lvec !< local values
2038	integer(ip_i4_p), intent(out):: gvec !< global values
2039	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2040	character(*),optional,intent(in) :: string !< to identify caller
2041	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2042
2043	!----- local ---
2044	character(*),parameter :: subname = '(oasis_mpi_mini0)'
2045	logical :: lall
2046	character(len=256) :: lstring
2047	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2048	integer(ip_i4_p) :: lsize
2049	integer(ip_i4_p) :: gsize
2050	integer(ip_i4_p) :: ierr
2051
2052	!-------------------------------------------------------------------------------
2053	! PURPOSE: Finds min of a distributed vector of values, assume local min
2054	! already computed
2055	!-------------------------------------------------------------------------------
2056
2057	call oasis_debug_enter(subname)
2058
2059	reduce_type = MPI_MIN
2060	if (present(all)) then
2061	lall = all
2062	else
2063	lall = .false.
2064	endif
2065	if (present(string)) then
2066	lstring = trim(subName)//":"//trim(string)
2067	else
2068	lstring = trim(subName)
2069	endif
2070
2071	lsize = 1
2072	gsize = 1
2073
2074	if (lsize /= gsize) then
2075	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2076	endif
2077
2078	if (lall) then
2079	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
2080	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2081	else
2082	call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
2083	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2084	endif
2085
2086	call oasis_debug_exit(subname)
2087
2088	END SUBROUTINE oasis_mpi_mini0
2089
2090	!===============================================================================
2091	!===============================================================================
2092
2093	!> Compute an array of global minimums for an array of 1D integers
2094
2095	SUBROUTINE oasis_mpi_mini1(lvec,gvec,comm,string,all)
2096
2097	IMPLICIT none
2098
2099	!----- arguments ---
2100	integer(ip_i4_p), intent(in) :: lvec(:) !< local values
2101	integer(ip_i4_p), intent(out):: gvec(:) !< global values
2102	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2103	character(*),optional,intent(in) :: string !< to identify caller
2104	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2105
2106	!----- local ---
2107	character(*),parameter :: subname = '(oasis_mpi_mini1)'
2108	logical :: lall
2109	character(len=256) :: lstring
2110	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2111	integer(ip_i4_p) :: lsize
2112	integer(ip_i4_p) :: gsize
2113	integer(ip_i4_p) :: ierr
2114
2115	!-------------------------------------------------------------------------------
2116	! PURPOSE: Finds min of a distributed vector of values, assume local min
2117	! already computed
2118	!-------------------------------------------------------------------------------
2119
2120	call oasis_debug_enter(subname)
2121
2122	reduce_type = MPI_MIN
2123	if (present(all)) then
2124	lall = all
2125	else
2126	lall = .false.
2127	endif
2128	if (present(string)) then
2129	lstring = trim(subName)//":"//trim(string)
2130	else
2131	lstring = trim(subName)
2132	endif
2133
2134	lsize = size(lvec)
2135	gsize = size(gvec)
2136
2137	if (lsize /= gsize) then
2138	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2139	endif
2140
2141	if (lall) then
2142	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
2143	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2144	else
2145	call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
2146	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2147	endif
2148
2149	call oasis_debug_exit(subname)
2150
2151	END SUBROUTINE oasis_mpi_mini1
2152
2153	!===============================================================================
2154	!===============================================================================
2155
2156	!> Compute an global minimum for a scalar double
2157
2158	SUBROUTINE oasis_mpi_minr0(lvec,gvec,comm,string,all)
2159
2160	IMPLICIT none
2161
2162	!----- arguments ---
2163	real(ip_double_p), intent(in) :: lvec !< local values
2164	real(ip_double_p), intent(out):: gvec !< global values
2165	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2166	character(*),optional,intent(in) :: string !< to identify caller
2167	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2168
2169	!----- local ---
2170	character(*),parameter :: subname = '(oasis_mpi_minr0)'
2171	logical :: lall
2172	character(len=256) :: lstring
2173	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2174	integer(ip_i4_p) :: lsize
2175	integer(ip_i4_p) :: gsize
2176	integer(ip_i4_p) :: ierr
2177
2178	!-------------------------------------------------------------------------------
2179	! PURPOSE: Finds min of a distributed vector of values, assume local min
2180	! already computed
2181	!-------------------------------------------------------------------------------
2182
2183	call oasis_debug_enter(subname)
2184
2185	reduce_type = MPI_MIN
2186	if (present(all)) then
2187	lall = all
2188	else
2189	lall = .false.
2190	endif
2191	if (present(string)) then
2192	lstring = trim(subName)//":"//trim(string)
2193	else
2194	lstring = trim(subName)
2195	endif
2196
2197	lsize = 1
2198	gsize = 1
2199
2200	if (lsize /= gsize) then
2201	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2202	endif
2203
2204	if (lall) then
2205	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
2206	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2207	else
2208	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
2209	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2210	endif
2211
2212	call oasis_debug_exit(subname)
2213
2214	END SUBROUTINE oasis_mpi_minr0
2215
2216	!===============================================================================
2217	!===============================================================================
2218
2219	!> Compute an array of global minimums for an array of 1D doubles
2220
2221	SUBROUTINE oasis_mpi_minr1(lvec,gvec,comm,string,all)
2222
2223	IMPLICIT none
2224
2225	!----- arguments ---
2226	real(ip_double_p), intent(in) :: lvec(:) !< local values
2227	real(ip_double_p), intent(out):: gvec(:) !< global values
2228	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2229	character(*),optional,intent(in) :: string !< to identify caller
2230	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2231
2232	!----- local ---
2233	character(*),parameter :: subname = '(oasis_mpi_minr1)'
2234	logical :: lall
2235	character(len=256) :: lstring
2236	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2237	integer(ip_i4_p) :: lsize
2238	integer(ip_i4_p) :: gsize
2239	integer(ip_i4_p) :: ierr
2240
2241	!-------------------------------------------------------------------------------
2242	! PURPOSE: Finds min of a distributed vector of values, assume local min
2243	! already computed
2244	!-------------------------------------------------------------------------------
2245
2246	call oasis_debug_enter(subname)
2247
2248	reduce_type = MPI_MIN
2249	if (present(all)) then
2250	lall = all
2251	else
2252	lall = .false.
2253	endif
2254	if (present(string)) then
2255	lstring = trim(subName)//":"//trim(string)
2256	else
2257	lstring = trim(subName)
2258	endif
2259
2260	lsize = size(lvec)
2261	gsize = size(gvec)
2262
2263	if (lsize /= gsize) then
2264	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2265	endif
2266
2267	if (lall) then
2268	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
2269	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2270	else
2271	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
2272	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2273	endif
2274
2275	call oasis_debug_exit(subname)
2276
2277	END SUBROUTINE oasis_mpi_minr1
2278
2279	!===============================================================================
2280	!===============================================================================
2281
2282	!> Compute a global maximum for a scalar integer
2283
2284	SUBROUTINE oasis_mpi_maxi0(lvec,gvec,comm,string,all)
2285
2286	IMPLICIT none
2287
2288	!----- arguments ---
2289	integer(ip_i4_p), intent(in) :: lvec !< local values
2290	integer(ip_i4_p), intent(out):: gvec !< global values
2291	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2292	character(*),optional,intent(in) :: string !< to identify caller
2293	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2294
2295	!----- local ---
2296	character(*),parameter :: subname = '(oasis_mpi_maxi0)'
2297	logical :: lall
2298	character(len=256) :: lstring
2299	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2300	integer(ip_i4_p) :: lsize
2301	integer(ip_i4_p) :: gsize
2302	integer(ip_i4_p) :: ierr
2303
2304	!-------------------------------------------------------------------------------
2305	! PURPOSE: Finds max of a distributed vector of values, assume local max
2306	! already computed
2307	!-------------------------------------------------------------------------------
2308
2309	call oasis_debug_enter(subname)
2310
2311	reduce_type = MPI_MAX
2312	if (present(all)) then
2313	lall = all
2314	else
2315	lall = .false.
2316	endif
2317	if (present(string)) then
2318	lstring = trim(subName)//":"//trim(string)
2319	else
2320	lstring = trim(subName)
2321	endif
2322
2323	lsize = 1
2324	gsize = 1
2325
2326	if (lsize /= gsize) then
2327	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2328	endif
2329
2330	if (lall) then
2331	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
2332	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2333	else
2334	call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
2335	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2336	endif
2337
2338	call oasis_debug_exit(subname)
2339
2340	END SUBROUTINE oasis_mpi_maxi0
2341
2342	!===============================================================================
2343	!===============================================================================
2344
2345	!> Compute an array of global maximums for an array of 1D integers
2346
2347	SUBROUTINE oasis_mpi_maxi1(lvec,gvec,comm,string,all)
2348
2349	IMPLICIT none
2350
2351	!----- arguments ---
2352	integer(ip_i4_p), intent(in) :: lvec(:) !< local values
2353	integer(ip_i4_p), intent(out):: gvec(:) !< global values
2354	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2355	character(*),optional,intent(in) :: string !< to identify caller
2356	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2357
2358	!----- local ---
2359	character(*),parameter :: subname = '(oasis_mpi_maxi1)'
2360	logical :: lall
2361	character(len=256) :: lstring
2362	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2363	integer(ip_i4_p) :: lsize
2364	integer(ip_i4_p) :: gsize
2365	integer(ip_i4_p) :: ierr
2366
2367	!-------------------------------------------------------------------------------
2368	! PURPOSE: Finds max of a distributed vector of values, assume local max
2369	! already computed
2370	!-------------------------------------------------------------------------------
2371
2372	call oasis_debug_enter(subname)
2373
2374	reduce_type = MPI_MAX
2375	if (present(all)) then
2376	lall = all
2377	else
2378	lall = .false.
2379	endif
2380	if (present(string)) then
2381	lstring = trim(subName)//":"//trim(string)
2382	else
2383	lstring = trim(subName)
2384	endif
2385
2386	lsize = size(lvec)
2387	gsize = size(gvec)
2388
2389	if (lsize /= gsize) then
2390	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2391	endif
2392
2393	if (lall) then
2394	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
2395	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2396	else
2397	call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
2398	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2399	endif
2400
2401	call oasis_debug_exit(subname)
2402
2403	END SUBROUTINE oasis_mpi_maxi1
2404
2405	!===============================================================================
2406	!===============================================================================
2407
2408	!> Compute a global maximum for a scalar double
2409
2410	SUBROUTINE oasis_mpi_maxr0(lvec,gvec,comm,string,all)
2411
2412	IMPLICIT none
2413
2414	!----- arguments ---
2415	real(ip_double_p), intent(in) :: lvec !< local values
2416	real(ip_double_p), intent(out):: gvec !< global values
2417	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2418	character(*),optional,intent(in) :: string !< to identify caller
2419	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2420
2421	!----- local ---
2422	character(*),parameter :: subname = '(oasis_mpi_maxr0)'
2423	logical :: lall
2424	character(len=256) :: lstring
2425	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2426	integer(ip_i4_p) :: lsize
2427	integer(ip_i4_p) :: gsize
2428	integer(ip_i4_p) :: ierr
2429
2430	!-------------------------------------------------------------------------------
2431	! PURPOSE: Finds max of a distributed vector of values, assume local max
2432	! already computed
2433	!-------------------------------------------------------------------------------
2434
2435	call oasis_debug_enter(subname)
2436
2437	reduce_type = MPI_MAX
2438	if (present(all)) then
2439	lall = all
2440	else
2441	lall = .false.
2442	endif
2443	if (present(string)) then
2444	lstring = trim(subName)//":"//trim(string)
2445	else
2446	lstring = trim(subName)
2447	endif
2448
2449	lsize = 1
2450	gsize = 1
2451
2452	if (lsize /= gsize) then
2453	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2454	endif
2455
2456	if (lall) then
2457	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
2458	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2459	else
2460	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
2461	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2462	endif
2463
2464	call oasis_debug_exit(subname)
2465
2466	END SUBROUTINE oasis_mpi_maxr0
2467
2468	!===============================================================================
2469	!===============================================================================
2470
2471	!> Compute an array of global maximums for an array of 1D doubles
2472
2473	SUBROUTINE oasis_mpi_maxr1(lvec,gvec,comm,string,all)
2474
2475	IMPLICIT none
2476
2477	!----- arguments ---
2478	real(ip_double_p), intent(in) :: lvec(:) !< local values
2479	real(ip_double_p), intent(out):: gvec(:) !< global values
2480	integer(ip_i4_p) , intent(in) :: comm !< mpi communicator
2481	character(*),optional,intent(in) :: string !< to identify caller
2482	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2483
2484	!----- local ---
2485	character(*),parameter :: subname = '(oasis_mpi_maxr1)'
2486	logical :: lall
2487	character(len=256) :: lstring
2488	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2489	integer(ip_i4_p) :: lsize
2490	integer(ip_i4_p) :: gsize
2491	integer(ip_i4_p) :: ierr
2492
2493	!-------------------------------------------------------------------------------
2494	! PURPOSE: Finds max of a distributed vector of values, assume local max
2495	! already computed
2496	!-------------------------------------------------------------------------------
2497
2498	call oasis_debug_enter(subname)
2499
2500	reduce_type = MPI_MAX
2501	if (present(all)) then
2502	lall = all
2503	else
2504	lall = .false.
2505	endif
2506	if (present(string)) then
2507	lstring = trim(subName)//":"//trim(string)
2508	else
2509	lstring = trim(subName)
2510	endif
2511
2512	lsize = size(lvec)
2513	gsize = size(gvec)
2514
2515	if (lsize /= gsize) then
2516	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2517	endif
2518
2519	if (lall) then
2520	call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
2521	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2522	else
2523	call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
2524	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2525	endif
2526
2527	call oasis_debug_exit(subname)
2528
2529	END SUBROUTINE oasis_mpi_maxr1
2530
2531	!===============================================================================
2532	!===============================================================================
2533
2534	!> Compute a global minimum and location for a distrbuted array of integers
2535
2536	SUBROUTINE oasis_mpi_minloci(lvec,lveca,gvec,gveca,comm,string,all)
2537
2538	IMPLICIT none
2539
2540	!----- arguments ---
2541	integer(ip_i4_p), intent(in) :: lvec(:) !< local values
2542	integer(ip_i4_p), intent(in) :: lveca(:) !< local location values
2543	integer(ip_i4_p), intent(out):: gvec(:) !< global values
2544	integer(ip_i4_p), intent(out):: gveca(:) !< global location value
2545	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2546	character(*),optional,intent(in) :: string !< to identify caller
2547	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2548
2549	!----- local ---
2550	character(*),parameter :: subname = '(oasis_mpi_minloci)'
2551	logical :: lall
2552	character(len=256) :: lstring
2553	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2554	integer(ip_i4_p) :: lsize
2555	integer(ip_i4_p) :: gsize
2556	integer(ip_i4_p),allocatable :: loc2(:,:),glo2(:,:)
2557	integer(ip_i4_p) :: n,ierr
2558
2559	!-------------------------------------------------------------------------------
2560	! PURPOSE: Finds min of a distributed vector of values, assume local min
2561	! already computed
2562	!-------------------------------------------------------------------------------
2563
2564	call oasis_debug_enter(subname)
2565
2566	reduce_type = MPI_MINLOC
2567	if (present(all)) then
2568	lall = all
2569	else
2570	lall = .false.
2571	endif
2572	if (present(string)) then
2573	lstring = trim(subName)//":"//trim(string)
2574	else
2575	lstring = trim(subName)
2576	endif
2577
2578	lsize = size(lvec)
2579	gsize = size(gvec)
2580
2581	if (lsize /= gsize .or. size(lveca) /= lsize .or. size(gveca) /= gsize) then
2582	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2583	endif
2584
2585	allocate(loc2(2,lsize))
2586	allocate(glo2(2,gsize))
2587
2588	glo2 = -999
2589	do n = 1,lsize
2590	loc2(1,n) = lvec(n)
2591	loc2(2,n) = lveca(n)
2592	enddo
2593
2594	if (lall) then
2595	call MPI_ALLREDUCE(loc2,glo2,gsize,MPI_2INTEGER,reduce_type,comm,ierr)
2596	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2597	else
2598	call MPI_REDUCE(loc2,glo2,gsize,MPI_2INTEGER,reduce_type,0,comm,ierr)
2599	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2600	endif
2601
2602	do n = 1,gsize
2603	gvec(n) = glo2(1,n)
2604	gveca(n) = glo2(2,n)
2605	enddo
2606
2607	deallocate(loc2,glo2)
2608
2609	call oasis_debug_exit(subname)
2610
2611	END SUBROUTINE oasis_mpi_minloci
2612
2613	!===============================================================================
2614
2615	!> Compute a global maximum and location for a distrbuted array of integers
2616
2617	SUBROUTINE oasis_mpi_maxloci(lvec,lveca,gvec,gveca,comm,string,all)
2618
2619	IMPLICIT none
2620
2621	!----- arguments ---
2622	integer(ip_i4_p), intent(in) :: lvec(:) !< local values
2623	integer(ip_i4_p), intent(in) :: lveca(:) !< local location values
2624	integer(ip_i4_p), intent(out):: gvec(:) !< global values
2625	integer(ip_i4_p), intent(out):: gveca(:) !< global location value
2626	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2627	character(*),optional,intent(in) :: string !< to identify caller
2628	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2629
2630	!----- local ---
2631	character(*),parameter :: subname = '(oasis_mpi_maxloci)'
2632	logical :: lall
2633	character(len=256) :: lstring
2634	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2635	integer(ip_i4_p) :: lsize
2636	integer(ip_i4_p) :: gsize
2637	integer(ip_i4_p),allocatable :: loc2(:,:),glo2(:,:)
2638	integer(ip_i4_p) :: n,ierr
2639
2640	!-------------------------------------------------------------------------------
2641	! PURPOSE: Finds max of a distributed vector of values, assume local max
2642	! already computed
2643	!-------------------------------------------------------------------------------
2644
2645	call oasis_debug_enter(subname)
2646
2647	reduce_type = MPI_MAXLOC
2648	if (present(all)) then
2649	lall = all
2650	else
2651	lall = .false.
2652	endif
2653	if (present(string)) then
2654	lstring = trim(subName)//":"//trim(string)
2655	else
2656	lstring = trim(subName)
2657	endif
2658
2659	lsize = size(lvec)
2660	gsize = size(gvec)
2661
2662	if (lsize /= gsize .or. size(lveca) /= lsize .or. size(gveca) /= gsize) then
2663	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2664	endif
2665
2666	allocate(loc2(2,lsize))
2667	allocate(glo2(2,gsize))
2668
2669	glo2 = -999
2670	do n = 1,lsize
2671	loc2(1,n) = lvec(n)
2672	loc2(2,n) = lveca(n)
2673	enddo
2674
2675	if (lall) then
2676	call MPI_ALLREDUCE(loc2,glo2,gsize,MPI_2INTEGER,reduce_type,comm,ierr)
2677	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2678	else
2679	call MPI_REDUCE(loc2,glo2,gsize,MPI_2INTEGER,reduce_type,0,comm,ierr)
2680	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2681	endif
2682
2683	do n = 1,gsize
2684	gvec(n) = glo2(1,n)
2685	gveca(n) = glo2(2,n)
2686	enddo
2687
2688	deallocate(loc2,glo2)
2689
2690	call oasis_debug_exit(subname)
2691
2692	END SUBROUTINE oasis_mpi_maxloci
2693
2694	!===============================================================================
2695	!===============================================================================
2696
2697	!> Compute a global minimum and location for a distrbuted array of reals
2698
2699	SUBROUTINE oasis_mpi_minlocr(lvec,lveca,gvec,gveca,comm,string,all)
2700
2701	IMPLICIT none
2702
2703	!----- arguments ---
2704	real(ip_double_p), intent(in) :: lvec(:) !< local values
2705	real(ip_double_p), intent(in) :: lveca(:) !< local location values
2706	real(ip_double_p), intent(out):: gvec(:) !< global values
2707	real(ip_double_p), intent(out):: gveca(:) !< global location value
2708	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2709	character(*),optional,intent(in) :: string !< to identify caller
2710	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2711
2712	!----- local ---
2713	character(*),parameter :: subname = '(oasis_mpi_minlocr)'
2714	logical :: lall
2715	character(len=256) :: lstring
2716	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2717	integer(ip_i4_p) :: lsize
2718	integer(ip_i4_p) :: gsize
2719	real(ip_double_p),allocatable:: loc2(:,:),glo2(:,:)
2720	integer(ip_i4_p) :: n,ierr
2721
2722	!-------------------------------------------------------------------------------
2723	! PURPOSE: Finds min of a distributed vector of values, assume local min
2724	! already computed
2725	!-------------------------------------------------------------------------------
2726
2727	call oasis_debug_enter(subname)
2728
2729	reduce_type = MPI_MINLOC
2730	if (present(all)) then
2731	lall = all
2732	else
2733	lall = .false.
2734	endif
2735	if (present(string)) then
2736	lstring = trim(subName)//":"//trim(string)
2737	else
2738	lstring = trim(subName)
2739	endif
2740
2741	lsize = size(lvec)
2742	gsize = size(gvec)
2743
2744	if (lsize /= gsize .or. size(lveca) /= lsize .or. size(gveca) /= gsize) then
2745	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2746	endif
2747
2748	allocate(loc2(2,lsize))
2749	allocate(glo2(2,gsize))
2750
2751	glo2 = -999
2752	do n = 1,lsize
2753	loc2(1,n) = lvec(n)
2754	loc2(2,n) = lveca(n)
2755	enddo
2756
2757	if (lall) then
2758	call MPI_ALLREDUCE(loc2,glo2,gsize,MPI_2DOUBLE_PRECISION,reduce_type,comm,ierr)
2759	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2760	else
2761	call MPI_REDUCE(loc2,glo2,gsize,MPI_2DOUBLE_PRECISION,reduce_type,0,comm,ierr)
2762	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2763	endif
2764
2765	do n = 1,gsize
2766	gvec(n) = glo2(1,n)
2767	gveca(n) = glo2(2,n)
2768	enddo
2769
2770	deallocate(loc2,glo2)
2771
2772	call oasis_debug_exit(subname)
2773
2774	END SUBROUTINE oasis_mpi_minlocr
2775
2776	!===============================================================================
2777
2778	!> Compute a global maximum and location for a distrbuted array of reals
2779
2780	SUBROUTINE oasis_mpi_maxlocr(lvec,lveca,gvec,gveca,comm,string,all)
2781
2782	IMPLICIT none
2783
2784	!----- arguments ---
2785	real(ip_double_p), intent(in) :: lvec(:) !< local values
2786	real(ip_double_p), intent(in) :: lveca(:) !< local location values
2787	real(ip_double_p), intent(out):: gvec(:) !< global values
2788	real(ip_double_p), intent(out):: gveca(:) !< global location value
2789	integer(ip_i4_p), intent(in) :: comm !< mpi communicator
2790	character(*),optional,intent(in) :: string !< to identify caller
2791	logical, optional,intent(in) :: all !< if true call allreduce, otherwise reduce to task 0
2792
2793	!----- local ---
2794	character(*),parameter :: subname = '(oasis_mpi_maxlocr)'
2795	logical :: lall
2796	character(len=256) :: lstring
2797	integer(ip_i4_p) :: reduce_type ! mpi reduction type
2798	integer(ip_i4_p) :: lsize
2799	integer(ip_i4_p) :: gsize
2800	real(ip_double_p),allocatable:: loc2(:,:),glo2(:,:)
2801	integer(ip_i4_p) :: n,ierr
2802
2803	!-------------------------------------------------------------------------------
2804	! PURPOSE: Finds max of a distributed vector of values, assume local max
2805	! already computed
2806	!-------------------------------------------------------------------------------
2807
2808	call oasis_debug_enter(subname)
2809
2810	reduce_type = MPI_MAXLOC
2811	if (present(all)) then
2812	lall = all
2813	else
2814	lall = .false.
2815	endif
2816	if (present(string)) then
2817	lstring = trim(subName)//":"//trim(string)
2818	else
2819	lstring = trim(subName)
2820	endif
2821
2822	lsize = size(lvec)
2823	gsize = size(gvec)
2824
2825	if (lsize /= gsize .or. size(lveca) /= lsize .or. size(gveca) /= gsize) then
2826	call oasis_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
2827	endif
2828
2829	allocate(loc2(2,lsize))
2830	allocate(glo2(2,gsize))
2831
2832	glo2 = -999
2833	do n = 1,lsize
2834	loc2(1,n) = lvec(n)
2835	loc2(2,n) = lveca(n)
2836	enddo
2837
2838	if (lall) then
2839	call MPI_ALLREDUCE(loc2,glo2,gsize,MPI_2DOUBLE_PRECISION,reduce_type,comm,ierr)
2840	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
2841	else
2842	call MPI_REDUCE(loc2,glo2,gsize,MPI_2DOUBLE_PRECISION,reduce_type,0,comm,ierr)
2843	call oasis_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
2844	endif
2845
2846	do n = 1,gsize
2847	gvec(n) = glo2(1,n)
2848	gveca(n) = glo2(2,n)
2849	enddo
2850
2851	deallocate(loc2,glo2)
2852
2853	call oasis_debug_exit(subname)
2854
2855	END SUBROUTINE oasis_mpi_maxlocr
2856
2857	!===============================================================================
2858	!===============================================================================
2859
2860	!> Get the total number of tasks associated with a communicator
2861
2862	SUBROUTINE oasis_mpi_commsize(comm,size,string)
2863
2864	IMPLICIT none
2865
2866	!----- arguments ---
2867	integer,intent(in) :: comm !< mpi communicator
2868	integer,intent(out) :: size !< output comm size
2869	character(*),optional,intent(in) :: string !< to identify caller
2870
2871	!----- local ---
2872	character(*),parameter :: subname = '(oasis_mpi_commsize)'
2873	integer(ip_i4_p) :: ierr
2874
2875	!-------------------------------------------------------------------------------
2876	! PURPOSE: MPI commsize
2877	!-------------------------------------------------------------------------------
2878
2879	call oasis_debug_enter(subname)
2880
2881	call MPI_COMM_SIZE(comm,size,ierr)
2882	if (present(string)) then
2883	call oasis_mpi_chkerr(ierr,subName//trim(string))
2884	else
2885	call oasis_mpi_chkerr(ierr,subName)
2886	endif
2887
2888	call oasis_debug_exit(subname)
2889
2890	END SUBROUTINE oasis_mpi_commsize
2891
2892	!===============================================================================
2893	!===============================================================================
2894
2895	!> Get the rank (task ID) for a task in a communicator
2896
2897	SUBROUTINE oasis_mpi_commrank(comm,rank,string)
2898
2899	IMPLICIT none
2900
2901	!----- arguments ---
2902	integer,intent(in) :: comm !< mpi communicator
2903	integer,intent(out) :: rank !< output task ID
2904	character(*),optional,intent(in) :: string !< to identify caller
2905
2906	!----- local ---
2907	character(*),parameter :: subname = '(oasis_mpi_commrank)'
2908	integer(ip_i4_p) :: ierr
2909
2910	!-------------------------------------------------------------------------------
2911	! PURPOSE: MPI commrank
2912	!-------------------------------------------------------------------------------
2913
2914	call oasis_debug_enter(subname)
2915
2916	call MPI_COMM_RANK(comm,rank,ierr)
2917	if (present(string)) then
2918	call oasis_mpi_chkerr(ierr,subName//trim(string))
2919	else
2920	call oasis_mpi_chkerr(ierr,subName)
2921	endif
2922
2923	call oasis_debug_exit(subname)
2924
2925	END SUBROUTINE oasis_mpi_commrank
2926
2927	!===============================================================================
2928	!===============================================================================
2929
2930	!> Check whether MPI has been initialized
2931
2932	SUBROUTINE oasis_mpi_initialized(flag,string)
2933
2934	IMPLICIT none
2935
2936	!----- arguments ---
2937	logical,intent(out) :: flag !< true if MPI_INITIALIZED has been called
2938	character(*),optional,intent(in) :: string !< to identify caller
2939
2940	!----- local ---
2941	character(*),parameter :: subName = '(oasis_mpi_initialized)'
2942	integer(ip_i4_p) :: ierr
2943
2944	!-------------------------------------------------------------------------------
2945	! PURPOSE: MPI initialized
2946	!-------------------------------------------------------------------------------
2947
2948	call oasis_debug_enter(subname)
2949
2950	call MPI_INITIALIZED(flag,ierr)
2951	if (present(string)) then
2952	call oasis_mpi_chkerr(ierr,subName//trim(string))
2953	else
2954	call oasis_mpi_chkerr(ierr,subName)
2955	endif
2956
2957	call oasis_debug_exit(subname)
2958
2959	END SUBROUTINE oasis_mpi_initialized
2960
2961	!===============================================================================
2962	!===============================================================================
2963
2964	!> Return a timestamp from MPI_WTIME
2965
2966	SUBROUTINE oasis_mpi_wtime(wtime)
2967
2968	IMPLICIT none
2969
2970	!----- arguments ---
2971	real(ip_r8_p), intent(out) :: wtime !< time in MPI_WTIME units
2972
2973	!----- local ---
2974	character(*),parameter :: subName = '(oasis_mpi_wtime)'
2975
2976	!-------------------------------------------------------------------------------
2977	! PURPOSE: MPI wtime
2978	!-------------------------------------------------------------------------------
2979
2980	call oasis_debug_enter(subname)
2981
2982	wtime = MPI_WTIME()
2983
2984	call oasis_debug_exit(subname)
2985
2986	END SUBROUTINE oasis_mpi_wtime
2987
2988	!===============================================================================
2989	!===============================================================================
2990
2991	!> Write error messages and Call MPI_ABORT
2992
2993	SUBROUTINE oasis_mpi_abort(string,rcode)
2994
2995	IMPLICIT none
2996
2997	!----- arguments ---
2998	character(*),optional,intent(in) :: string !< to identify caller
2999	integer,optional,intent(in) :: rcode !< optional code
3000
3001	!----- local ---
3002	character(*),parameter :: subName = '(oasis_mpi_abort)'
3003	character(len=256) :: lstr
3004	integer(ip_i4_p) :: ierr
3005	integer :: rc ! return code
3006
3007	!-------------------------------------------------------------------------------
3008	! PURPOSE: MPI abort
3009	!-------------------------------------------------------------------------------
3010
3011	call oasis_debug_enter(subname)
3012
3013	if ( present(string) .and. present(rcode)) then
3014	write(lstr,'(a,i6.6)') trim(string)//' rcode = ',rcode
3015	elseif (present(string)) then
3016	lstr = trim(string)
3017	else
3018	lstr = ' '
3019	endif
3020
3021	IF ( PRESENT(rcode)) THEN
3022	CALL oasis_abort(cd_routine=subName,cd_message=TRIM(string),file=__FILE__,line=__LINE__,rcode=rcode)
3023	ELSE
3024	CALL oasis_abort(cd_routine=subName,cd_message=TRIM(string),file=__FILE__,line=__LINE__)
3025	ENDIF
3026
3027	call oasis_debug_exit(subname)
3028
3029	END SUBROUTINE oasis_mpi_abort
3030
3031	!===============================================================================
3032	!===============================================================================
3033
3034	!> Call MPI_BARRIER for a particular communicator
3035
3036	SUBROUTINE oasis_mpi_barrier(comm,string)
3037
3038	IMPLICIT none
3039
3040	!----- arguments ---
3041	integer,intent(in) :: comm !< mpi communicator
3042	character(*),optional,intent(in) :: string !< to identify caller
3043
3044	!----- local ---
3045	character(*),parameter :: subname = '(oasis_mpi_barrier)'
3046	integer(ip_i4_p) :: ierr
3047
3048	!-------------------------------------------------------------------------------
3049	! PURPOSE: MPI barrier
3050	!-------------------------------------------------------------------------------
3051
3052	call oasis_debug_enter(subname)
3053
3054	call MPI_BARRIER(comm,ierr)
3055	if (present(string)) then
3056	call oasis_mpi_chkerr(ierr,subName//trim(string))
3057	else
3058	call oasis_mpi_chkerr(ierr,subName)
3059	endif
3060
3061	call oasis_debug_exit(subname)
3062
3063	END SUBROUTINE oasis_mpi_barrier
3064
3065	!===============================================================================
3066	!===============================================================================
3067
3068	!> Call MPI_INIT
3069
3070	SUBROUTINE oasis_mpi_init(string)
3071
3072	IMPLICIT none
3073
3074	!----- arguments ---
3075	character(*),optional,intent(in) :: string !< to identify caller
3076
3077	!----- local ---
3078	character(*),parameter :: subname = '(oasis_mpi_init)'
3079	integer(ip_i4_p) :: ierr
3080
3081	!-------------------------------------------------------------------------------
3082	! PURPOSE: MPI init
3083	!-------------------------------------------------------------------------------
3084
3085	call oasis_debug_enter(subname)
3086
3087	call MPI_INIT(ierr)
3088	if (present(string)) then
3089	call oasis_mpi_chkerr(ierr,subName//trim(string))
3090	else
3091	call oasis_mpi_chkerr(ierr,subName)
3092	endif
3093
3094	call oasis_debug_exit(subname)
3095
3096	END SUBROUTINE oasis_mpi_init
3097
3098	!===============================================================================
3099	!===============================================================================
3100
3101	!> Call MPI_FINALZE
3102
3103	SUBROUTINE oasis_mpi_finalize(string)
3104
3105	IMPLICIT none
3106
3107	!----- arguments ---
3108	character(*),optional,intent(in) :: string !< to identify caller
3109
3110	!----- local ---
3111	character(*),parameter :: subname = '(oasis_mpi_finalize)'
3112	integer(ip_i4_p) :: ierr
3113
3114	!-------------------------------------------------------------------------------
3115	! PURPOSE: MPI finalize
3116	!-------------------------------------------------------------------------------
3117
3118	call oasis_debug_enter(subname)
3119
3120	call MPI_FINALIZE(ierr)
3121	if (present(string)) then
3122	call oasis_mpi_chkerr(ierr,subName//trim(string))
3123	else
3124	call oasis_mpi_chkerr(ierr,subName)
3125	endif
3126
3127	call oasis_debug_exit(subname)
3128
3129	END SUBROUTINE oasis_mpi_finalize
3130
3131	!===============================================================================
3132	!===============================================================================
3133
3134	!> Custom method for reducing MPI lists across pes for OASIS
3135
3136	SUBROUTINE oasis_mpi_reducelists(linp1,comm,cntout,lout1,callstr,fastcheck,fastcheckout, &
3137	linp2,lout2,spval2,linp3,lout3,spval3,linp4,lout4,spval4)
3138
3139	IMPLICIT none
3140
3141	!----- arguments ---
3142	character(*),allocatable,intent(inout) :: linp1(:) !< input list on each task
3143	integer ,intent(in) :: comm !< mpi communicator
3144	integer ,intent(out) :: cntout !< size of lout1 list
3145	character(*),allocatable,intent(inout) :: lout1(:) !< reduced output list, same on all tasks
3146	character(*) ,intent(in) :: callstr !< to identify caller
3147	logical ,intent(in) ,optional :: fastcheck !< run a fastcheck first
3148	logical ,intent(out) ,optional :: fastcheckout !< true if fastcheck worked
3149	character(*),allocatable,intent(inout),optional :: linp2(:) !< input list on each task
3150	character(*),allocatable,intent(inout),optional :: lout2(:) !< reduced output list, same on all tasks
3151	character(*) ,intent(in) ,optional :: spval2 !< unset value for linp2
3152	integer ,allocatable,intent(in) ,optional :: linp3(:) !< input list on each task
3153	integer ,allocatable,intent(inout),optional :: lout3(:) !< reduced output list, same on all tasks
3154	integer ,intent(in) ,optional :: spval3 !< unset value for linp3
3155	integer ,allocatable,intent(in) ,optional :: linp4(:) !< input list on each task
3156	integer ,allocatable,intent(inout),optional :: lout4(:) !< reduced output list, same on all tasks
3157	integer ,intent(in) ,optional :: spval4 !< unset value for linp4
3158
3159	!----- local ---
3160	integer(kind=ip_i4_p) :: m,n,k,p
3161	integer(kind=ip_i4_p) :: llen,lsize
3162	integer(kind=ip_i4_p) :: cnt, cntr
3163	integer(kind=ip_i4_p) :: commrank, commsize
3164	integer(kind=ip_i4_p) :: listcheck, listcheckall
3165	integer(kind=ip_i4_p) :: maxloops, sendid, recvid, kfac
3166	logical :: found, present2, present3, present4
3167	integer(kind=ip_i4_p) :: status(MPI_STATUS_SIZE) ! mpi status info
3168	character(len=ic_lvar2),pointer :: recv_varf1(:),varf1a(:),varf1b(:)
3169	character(len=ic_lvar2),pointer :: recv_varf2(:),varf2a(:),varf2b(:)
3170	integer(kind=ip_i4_p) ,pointer :: recv_varf3(:),varf3a(:),varf3b(:)
3171	integer(kind=ip_i4_p) ,pointer :: recv_varf4(:),varf4a(:),varf4b(:)
3172	character(len=ic_lvar2) :: string
3173	logical, parameter :: local_timers_on = .false.
3174	integer(ip_i4_p) :: ierr
3175	character(*),parameter :: subname = '(oasis_mpi_reducelists)'
3176
3177	!-------------------------------------------------------------------------------
3178	! PURPOSE: Custom method for reducing MPI lists for OASIS using a log2
3179	! algorithm. This generates a list on all tasks that consists of the intersection
3180	! of all the values on all the tasks with each value listed once. linp1
3181	! is the input list, possibly different on each task. lout1
3182	! is the resulting list, the same on each task, consistenting of all unique
3183	! values of linp1 from all tasks. This ultimately reduces the list onto
3184	! the root task and then it's broadcast. The reduction occurs via a binary
3185	! type reduction from tasks to other tasks.
3186	!-------------------------------------------------------------------------------
3187
3188	call oasis_debug_enter(subname)
3189
3190	string = trim(callstr)
3191	if (present(fastcheckout)) fastcheckout = .false. ! by default
3192	call oasis_mpi_commrank(comm,commrank,string=subname//trim(string))
3193	call oasis_mpi_commsize(comm,commsize,string=subname//trim(string))
3194
3195	!-----------------------------------------------
3196	!> * Check argument consistency
3197	!-----------------------------------------------
3198
3199	if ((present(linp2) .and. .not.present(lout2)) .or. &
3200	(present(lout2) .and. .not.present(linp2))) then
3201	call oasis_mpi_abort(subname//trim(string)//" linp2 lout2 both must be present ")
3202	endif
3203	present2 = present(linp2)
3204
3205	if ((present(linp3) .and. .not.present(lout3)) .or. &
3206	(present(lout3) .and. .not.present(linp3))) then
3207	call oasis_mpi_abort(subname//trim(string)//" linp3 lout3 both must be present ")
3208	endif
3209	present3 = present(linp3)
3210
3211	if ((present(linp4) .and. .not.present(lout4)) .or. &
3212	(present(lout4) .and. .not.present(linp4))) then
3213	call oasis_mpi_abort(subname//trim(string)//" linp4 lout4 both must be present ")
3214	endif
3215	present4 = present(linp4)
3216
3217	if (len(linp1) > len(varf1a)) then
3218	call oasis_mpi_abort(subname//trim(string)//" linp1 too long ")
3219	endif
3220
3221	if (present(linp2)) then
3222	if (size(linp2) /= size(linp1)) then
3223	call oasis_mpi_abort(subname//trim(string)//" linp1 linp2 not same size ")
3224	endif
3225	if (len(linp2) > len(varf2a)) then
3226	call oasis_mpi_abort(subname//trim(string)//" linp2 too long ")
3227	endif
3228	if (len(varf1a) /= len(varf2a)) then
3229	call oasis_mpi_abort(subname//trim(string)//" varf1a varf2a not same len ")
3230	endif
3231	endif
3232
3233	if (present(linp3)) then
3234	if (size(linp3) /= size(linp1)) then
3235	call oasis_mpi_abort(subname//trim(string)//" linp1 linp3 not same size ")
3236	endif
3237	endif
3238
3239	if (present(linp4)) then
3240	if (size(linp4) /= size(linp1)) then
3241	call oasis_mpi_abort(subname//trim(string)//" linp1 linp4 not same size ")
3242	endif
3243	endif
3244
3245	!-----------------------------------------------
3246	!> * Fast compare on all tasks
3247	! If all tasks have same list, just skip the reduction
3248	!-----------------------------------------------
3249
3250	if (present(fastcheck)) then
3251	if (fastcheck) then
3252
3253	if (local_timers_on) call oasis_timer_start(trim(string)//'_rl_fastcheck')
3254
3255	lsize = -1
3256	if (commrank == 0) then
3257	lsize = size(linp1)
3258	endif
3259	call oasis_mpi_bcast(lsize, comm, subname//trim(string)//' lsize check')
3260
3261	! varf1a holds linp1 from root on all tasks
3262	allocate(varf1a(lsize))
3263	varf1a = ' '
3264	if (commrank == 0) then
3265	varf1a(1:lsize) = linp1(1:lsize)
3266	endif
3267	call oasis_mpi_bcast(varf1a, comm, subname//trim(string)//' varf1a check')
3268
3269	listcheck = 1
3270	if (OASIS_DEBUG >= 20) then
3271	write(nulprt,*) subname//trim(string),' sizes ',lsize,size(linp1)
3272	endif
3273	if (lsize /= size(linp1)) listcheck = 0
3274	n = 0
3275	do while (listcheck == 1 .and. n < lsize)
3276	n = n + 1
3277	if (varf1a(n) /= linp1(n)) listcheck = 0
3278	if (OASIS_DEBUG >= 20) then
3279	write(nulprt,*) subname//trim(string),' fcheck varf1a ',n,trim(linp1(n)),' ',trim(linp1(n)),listcheck
3280	endif
3281	enddo
3282	deallocate(varf1a)
3283	call oasis_mpi_min(listcheck,listcheckall,comm, subname//trim(string)//' listcheck',all=.true.)
3284
3285	if (OASIS_DEBUG >= 15) then
3286	write(nulprt,*) subname//trim(string),' listcheck = ',listcheck,listcheckall
3287	endif
3288	if (local_timers_on) call oasis_timer_stop(trim(string)//'_rl_fastcheck')
3289
3290	!-------------------------------------------------
3291	! linp1 same on all tasks, update lout1, lout2, lout3, lout4 and return
3292	!-------------------------------------------------
3293
3294	if (listcheckall == 1) then
3295	cntout = lsize
3296	allocate(lout1(lsize))
3297	lout1(1:lsize) = linp1(1:lsize)
3298	if (present2) then
3299	allocate(lout2(lsize))
3300	lout2(1:lsize) = linp2(1:lsize)
3301	endif
3302	if (present3) then
3303	allocate(lout3(lsize))
3304	lout3(1:lsize) = linp3(1:lsize)
3305	endif
3306	if (present4) then
3307	allocate(lout4(lsize))
3308	lout4(1:lsize) = linp4(1:lsize)
3309	endif
3310	call oasis_debug_exit(subname)
3311	if (present(fastcheckout)) fastcheckout = .true.
3312	return
3313	endif
3314
3315	endif ! fastcheck
3316	endif ! present fastcheck
3317
3318	!-----------------------------------------------
3319	!> * Generate initial unique local name list
3320	!-----------------------------------------------
3321
3322	llen = len(linp1)
3323	lsize = size(linp1)
3324	if (OASIS_Debug >= 15) then
3325	write(nulprt,*) subname//trim(string),' len, size = ',llen,lsize
3326	call oasis_flush(nulprt)
3327	endif
3328
3329	allocate(varf1a(max(lsize,20))) ! 20 is arbitrary starting number
3330	if (present2) allocate(varf2a(max(lsize,20))) ! 20 is arbitrary starting number
3331	if (present3) allocate(varf3a(max(lsize,20))) ! 20 is arbitrary starting number
3332	if (present4) allocate(varf4a(max(lsize,20))) ! 20 is arbitrary starting number
3333	cnt = 0
3334	do n = 1,lsize
3335	p = 0
3336	found = .false.
3337	do while (p < cnt .and. .not.found)
3338	p = p + 1
3339	if (linp1(n) == varf1a(p)) found = .true.
3340	enddo
3341	if (.not.found) then
3342	cnt = cnt + 1
3343	varf1a(cnt) = linp1(n)
3344	if (present2) varf2a(cnt) = linp2(n)
3345	if (present3) varf3a(cnt) = linp3(n)
3346	if (present4) varf4a(cnt) = linp4(n)
3347	endif
3348	enddo
3349
3350	!-----------------------------------------------
3351	!> * Log2 reduction of linp over tasks to root
3352	!-----------------------------------------------
3353
3354	maxloops = int(log(float(commsize+1)/log(2.)))+1
3355	do m = 1,maxloops
3356
3357	kfac = 2**m
3358
3359	recvid = commrank + kfac/2 ! task to recv from
3360	if (mod(commrank,kfac) /= 0 .or. &
3361	recvid < 0 .or. recvid > commsize-1) &
3362	recvid = -1
3363
3364	sendid = commrank - kfac/2 ! task to send to
3365	if (mod(commrank+kfac/2,kfac) /= 0 .or. &
3366	sendid < 0 .or. sendid > commsize-1) &
3367	sendid = -1
3368
3369	if (OASIS_Debug >= 15) then
3370	write(nulprt,*) subname//trim(string),' send/recv ids ',m,commrank,sendid,recvid
3371	call oasis_flush(nulprt)
3372	endif
3373
3374	!-----------------------------------------------
3375	!> * Send list
3376	!-----------------------------------------------
3377
3378	if (sendid >= 0) then
3379	if (local_timers_on) call oasis_timer_start(trim(string)//'_rl_send')
3380	call MPI_SEND(cnt, 1, MPI_INTEGER, sendid, 5900+m, comm, ierr)
3381	call oasis_mpi_chkerr(ierr,subname//trim(string)//':send cnt')
3382	if (cnt > 0) then
3383	if (OASIS_Debug >= 15) then
3384	write(nulprt,*) subname//trim(string),' send size ',commrank,m,cnt,ic_lvar2
3385	call oasis_flush(nulprt)
3386	endif
3387	call MPI_SEND(varf1a(1:cnt), cnt*ic_lvar2, MPI_CHARACTER, sendid, 6900+m, comm, ierr)
3388	call oasis_mpi_chkerr(ierr,subname//trim(string)//':send varf1a')
3389	if (present2) then
3390	call MPI_SEND(varf2a(1:cnt), cnt*ic_lvar2, MPI_CHARACTER, sendid, 7900+m, comm, ierr)
3391	call oasis_mpi_chkerr(ierr,subname//trim(string)//':send varf2a')
3392	endif
3393	if (present3) then
3394	call MPI_SEND(varf3a(1:cnt), cnt, MPI_INTEGER, sendid, 8900+m, comm, ierr)
3395	call oasis_mpi_chkerr(ierr,subname//trim(string)//':send varf3a')
3396	endif
3397	if (present4) then
3398	call MPI_SEND(varf4a(1:cnt), cnt, MPI_INTEGER, sendid, 9900+m, comm, ierr)
3399	call oasis_mpi_chkerr(ierr,subname//trim(string)//':send varf4a')
3400	endif
3401	endif ! cnt > 0
3402	if (local_timers_on) call oasis_timer_stop (trim(string)//'_rl_send')
3403	endif ! sendid >= 0
3404
3405	!-----------------------------------------------
3406	!> * Recv list
3407	!> * Determine the unique list
3408	!-----------------------------------------------
3409
3410	if (recvid >= 0) then
3411	if (local_timers_on) call oasis_timer_start (trim(string)//'_rl_recv')
3412	call MPI_RECV(cntr, 1, MPI_INTEGER, recvid, 5900+m, comm, status, ierr)
3413	call oasis_mpi_chkerr(ierr,subname//trim(string)//':recv cntr')
3414	if (cntr > 0) then
3415	if (OASIS_Debug >= 15) then
3416	write(nulprt,*) subname//trim(string),' recv size ',commrank,m,cntr,ic_lvar2
3417	call oasis_flush(nulprt)
3418	endif
3419	allocate(recv_varf1(cntr))
3420	call MPI_RECV(recv_varf1, cntr*ic_lvar2, MPI_CHARACTER, recvid, 6900+m, comm, status, ierr)
3421	call oasis_mpi_chkerr(ierr,subname//trim(string)//':recv varf1')
3422	if (present2) then
3423	allocate(recv_varf2(cntr))
3424	call MPI_RECV(recv_varf2, cntr*ic_lvar2, MPI_CHARACTER, recvid, 7900+m, comm, status, ierr)
3425	call oasis_mpi_chkerr(ierr,subname//trim(string)//':recv varf2')
3426	endif
3427	if (present3) then
3428	allocate(recv_varf3(cntr))
3429	call MPI_RECV(recv_varf3, cntr, MPI_INTEGER, recvid, 8900+m, comm, status, ierr)
3430	call oasis_mpi_chkerr(ierr,subname//trim(string)//':recv varf3')
3431	endif
3432	if (present4) then
3433	allocate(recv_varf4(cntr))
3434	call MPI_RECV(recv_varf4, cntr, MPI_INTEGER, recvid, 9900+m, comm, status, ierr)
3435	call oasis_mpi_chkerr(ierr,subname//trim(string)//':recv varf4')
3436	endif
3437	endif ! cntr > 0
3438	if (local_timers_on) call oasis_timer_stop (trim(string)//'_rl_recv')
3439
3440	if (local_timers_on) call oasis_timer_start(trim(string)//'_rl_rootsrch')
3441	do n = 1,cntr
3442	if (OASIS_Debug >= 15) write(nulprt,*) subname//trim(string),' check recv_varf1 ',m,n,trim(recv_varf1(n))
3443
3444	p = 0
3445	found = .false.
3446	do while (p < cnt .and. .not.found)
3447	p = p + 1
3448	if (recv_varf1(n) == varf1a(p)) then
3449	found = .true.
3450	if (present2) then
3451	if (present(spval2)) then
3452	!--- use something other than spval2 if it exists and check consistency
3453	if (varf2a(p) == spval2) then
3454	varf2a(p) = recv_varf2(n)
3455	elseif (recv_varf2(n) /= spval2 .and. varf2a(p) /= recv_varf2(n)) then
3456	call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3457	'inconsistent linp2 value: '//trim(recv_varf2(n))//':'//trim(varf1a(p))//':'//trim(varf2a(p)), &
3458	file=__FILE__,line=__LINE__)
3459	endif
3460	else
3461	if (varf2a(p) /= recv_varf2(n)) then
3462	call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3463	'inconsistent linp2 value: '//trim(recv_varf2(n))//':'//trim(varf1a(p))//':'//trim(varf2a(p)), &
3464	file=__FILE__,line=__LINE__)
3465	endif
3466	endif
3467	endif
3468	if (present3) then
3469	if (present(spval3)) then
3470	!--- use something other than spval3 if it exists and check consistency
3471	if (varf3a(p) == spval3) then
3472	varf3a(p) = recv_varf3(n)
3473	elseif (recv_varf3(n) /= spval3 .and. varf3a(p) /= recv_varf3(n)) then
3474	write(nulprt,*) subname//trim(string),astr,'inconsistent linp3 var: ',&
3475	recv_varf3(n),':',trim(varf1a(p)),':',varf3a(p)
3476	call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3477	'inconsistent linp3 value: '//trim(varf1a(p)), &
3478	file=__FILE__,line=__LINE__)
3479	endif
3480	else
3481	if (varf3a(p) /= recv_varf3(n)) then
3482	write(nulprt,*) subname//trim(string),astr,'inconsistent linp3 var: ',&
3483	recv_varf3(n),':',trim(varf1a(p)),':',varf3a(p)
3484	call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3485	'inconsistent linp3 value: '//trim(varf1a(p)), &
3486	file=__FILE__,line=__LINE__)
3487	endif
3488	endif
3489	endif
3490	if (present4) then
3491	if (present(spval4)) then
3492	!--- use something other than spval4 if it exists and check consistency
3493	if (varf4a(p) == spval4) then
3494	varf4a(p) = recv_varf4(n)
3495	elseif (recv_varf4(n) /= spval4 .and. varf4a(p) /= recv_varf4(n)) then
3496	write(nulprt,*) subname//trim(string),astr,'inconsistent linp4 var: ',&
3497	recv_varf4(n),':',trim(varf1a(p)),':',varf4a(p)
3498	call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3499	'inconsistent linp4 value: '//trim(varf1a(p)), &
3500	file=__FILE__,line=__LINE__)
3501	endif
3502	else
3503	if (varf4a(p) /= recv_varf4(n)) then
3504	write(nulprt,*) subname//trim(string),astr,'inconsistent linp4 var: ',&
3505	recv_varf4(n),':',trim(varf1a(p)),':',varf4a(p)
3506	call oasis_abort(cd_routine=subname//trim(string),cd_message= &
3507	'inconsistent linp4 value: '//trim(varf1a(p)), &
3508	file=__FILE__,line=__LINE__)
3509	endif
3510	endif
3511	endif
3512	endif
3513	enddo
3514	if (.not.found) then
3515	cnt = cnt + 1
3516	if (cnt > size(varf1a)) then
3517	allocate(varf1b(size(varf1a)))
3518	varf1b = varf1a
3519	deallocate(varf1a)
3520	if (OASIS_Debug >= 15) then
3521	write(nulprt,*) subname//trim(string),' resize varf1a ',size(varf1b),cnt+cntr
3522	call oasis_flush(nulprt)
3523	endif
3524	allocate(varf1a(cnt+cntr))
3525	varf1a(1:size(varf1b)) = varf1b(1:size(varf1b))
3526	deallocate(varf1b)
3527	if (present2) then
3528	allocate(varf2b(size(varf2a)))
3529	varf2b = varf2a
3530	deallocate(varf2a)
3531	if (OASIS_Debug >= 15) then
3532	write(nulprt,*) subname//trim(string),' resize varf2a ',size(varf2b),cnt+cntr
3533	call oasis_flush(nulprt)
3534	endif
3535	allocate(varf2a(cnt+cntr))
3536	varf2a(1:size(varf2b)) = varf2b(1:size(varf2b))
3537	deallocate(varf2b)
3538	endif
3539	if (present3) then
3540	allocate(varf3b(size(varf3a)))
3541	varf3b = varf3a
3542	deallocate(varf3a)
3543	if (OASIS_Debug >= 15) then
3544	write(nulprt,*) subname//trim(string),' resize varf3a ',size(varf3b),cnt+cntr
3545	call oasis_flush(nulprt)
3546	endif
3547	allocate(varf3a(cnt+cntr))
3548	varf3a(1:size(varf3b)) = varf3b(1:size(varf3b))
3549	deallocate(varf3b)
3550	endif
3551	if (present4) then
3552	allocate(varf4b(size(varf4a)))
3553	varf4b = varf4a
3554	deallocate(varf4a)
3555	if (OASIS_Debug >= 15) then
3556	write(nulprt,*) subname//trim(string),' resize varf4a ',size(varf4b),cnt+cntr
3557	call oasis_flush(nulprt)
3558	endif
3559	allocate(varf4a(cnt+cntr))
3560	varf4a(1:size(varf4b)) = varf4b(1:size(varf4b))
3561	deallocate(varf4b)
3562	endif
3563	endif
3564	varf1a(cnt) = recv_varf1(n)
3565	if (present2) varf2a(cnt) = recv_varf2(n)
3566	if (present3) varf3a(cnt) = recv_varf3(n)
3567	if (present4) varf4a(cnt) = recv_varf4(n)
3568	endif
3569	enddo ! cntr
3570	if (local_timers_on) call oasis_timer_stop(trim(string)//'_rl_rootsrch')
3571	if (cntr > 0) then
3572	deallocate(recv_varf1)
3573	if (present2) deallocate(recv_varf2)
3574	if (present3) deallocate(recv_varf3)
3575	if (present4) deallocate(recv_varf4)
3576	endif
3577
3578	endif ! recvid >= 0
3579
3580	enddo ! maxloops
3581
3582	!-------------------------------------------------
3583	!> * Broadcast the list information to all tasks from root
3584	!-------------------------------------------------
3585
3586	if (local_timers_on) then
3587	call oasis_timer_start(trim(string)//'_rl_bcast_barrier')
3588	if (comm /= MPI_COMM_NULL) &
3589	call MPI_BARRIER(comm, ierr)
3590	call oasis_timer_stop(trim(string)//'_rl_bcast_barrier')
3591	endif
3592	if (local_timers_on) call oasis_timer_start(trim(string)//'_rl_bcast')
3593	call oasis_mpi_bcast(cnt,comm,subname//trim(string)//' cnt')
3594	cntout = cnt
3595	allocate(lout1(cntout))
3596	if (commrank == 0) then
3597	do n = 1,cntout
3598	lout1(n) = trim(varf1a(n))
3599	enddo
3600	endif
3601	deallocate(varf1a)
3602	call oasis_mpi_bcast(lout1,comm,subname//trim(string)//' lout1')
3603
3604	if (present2) then
3605	allocate(lout2(cntout))
3606	if (commrank == 0) then
3607	do n = 1,cntout
3608	lout2(n) = trim(varf2a(n))
3609	enddo
3610	endif
3611	deallocate(varf2a)
3612	call oasis_mpi_bcast(lout2,comm,subname//trim(string)//' lout2')
3613	endif
3614
3615	if (present3) then
3616	allocate(lout3(cntout))
3617	if (commrank == 0) then
3618	do n = 1,cntout
3619	lout3(n) = varf3a(n)
3620	enddo
3621	endif
3622	deallocate(varf3a)
3623	call oasis_mpi_bcast(lout3,comm,subname//trim(string)//' lout3')
3624	endif
3625
3626	if (present4) then
3627	allocate(lout4(cntout))
3628	if (commrank == 0) then
3629	do n = 1,cntout
3630	lout4(n) = varf4a(n)
3631	enddo
3632	endif
3633	deallocate(varf4a)
3634	call oasis_mpi_bcast(lout4,comm,subname//trim(string)//' lout4')
3635	endif
3636
3637	!--- document
3638
3639	if (OASIS_debug >= 15) then
3640	do n = 1,cnt
3641	if (present2 .and. present3 .and. present4) then
3642	write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),' ',trim(lout2(n)),lout3(n),lout4(n)
3643	elseif (present2 .and. present3) then
3644	write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),' ',trim(lout2(n)),lout3(n)
3645	elseif (present2 .and. present4) then
3646	write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),' ',trim(lout2(n)),lout4(n)
3647	elseif (present3 .and. present4) then
3648	write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),' ',lout3(n),lout4(n)
3649	elseif (present2) then
3650	write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),' ',trim(lout2(n))
3651	elseif (present3) then
3652	write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),lout3(n)
3653	elseif (present4) then
3654	write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n)),lout4(n)
3655	else
3656	write(nulprt,*) subname,trim(string),' list: ',n,trim(lout1(n))
3657	endif
3658	enddo
3659	call oasis_flush(nulprt)
3660	endif
3661	if (local_timers_on) call oasis_timer_stop (trim(string)//'_rl_bcast')
3662
3663	call oasis_debug_exit(subname)
3664
3665	END SUBROUTINE oasis_mpi_reducelists
3666
3667	!===============================================================================
3668	!===============================================================================
3669
3670	END MODULE mod_oasis_mpi

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: CPL/oasis3-mct/branches/OASIS3-MCT_5.0_branch/lib/psmile/src/mod_oasis_mpi.F90 @ 6331

Download in other formats: